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

Changeset 14048


Ignore:
Timestamp:
2020-12-03T13:17:01+01:00 (4 years ago)
Author:
cetlod
Message:

dev_r13312_AGRIF-03-04_jchanut : phasing agrif_top_update.F90 with what is done in agrif_oce_update.F90

File:
1 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_top_update.F90

    r12489 r14048  
    4040      IF (Agrif_Root()) RETURN  
    4141      ! 
    42       Agrif_UseSpecialValueInUpdate = .TRUE. 
     42      l_vremap                      = ln_vert_remap 
     43      Agrif_UseSpecialValueInUpdate = .NOT.l_vremap 
    4344      Agrif_SpecialValueFineGrid    = 0._wp 
     45 
    4446      !  
    4547# if ! defined DECAL_FEEDBACK 
    … …  
    5254      ! 
    5355      Agrif_UseSpecialValueInUpdate = .FALSE. 
     56      l_vremap                      = .FALSE. 
    5457      ! 
    5558   END SUBROUTINE Agrif_Update_Trc 
    5659 
    57 #ifdef key_vertical 
    5860   SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    59       !!--------------------------------------------- 
    60       !!           *** ROUTINE updateT *** 
    61       !!--------------------------------------------- 
     61 
    6262      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    6363      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    … …  
    7272      REAL(wp) :: tabin(k1:k2,1:jptra) 
    7373      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: tabres_child 
    74       !!--------------------------------------------- 
    75       ! 
     74 
    7675      IF (before) THEN 
    77          AGRIF_SpecialValue = -999._wp 
    78          DO jn = n1,n2-1 
     76         IF ( l_vremap ) THEN 
     77            DO jn = n1,n2-1 
     78               DO jk=k1,k2 
     79                  DO jj=j1,j2 
     80                     DO ji=i1,i2 
     81                        tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) 
     82                     END DO 
     83                  END DO 
     84               END DO 
     85            END DO 
    7986            DO jk=k1,k2 
    8087               DO jj=j1,j2 
    8188                  DO ji=i1,i2 
    82                      tabres(ji,jj,jk,jn) = (tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) ) & 
    83                                            * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp 
    84                   END DO 
    85                END DO 
    86             END DO 
    87          END DO 
    88          DO jk=k1,k2 
     89                     tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 
     90                  END DO 
     91               END DO 
     92            END DO 
     93         ELSE 
     94            DO jn = 1,jptra 
     95               DO jk=k1,k2 
     96                  DO jj=j1,j2 
     97                     DO ji=i1,i2 
     98                        tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk) 
     99                     END DO 
     100                  END DO 
     101               END DO 
     102            END DO 
     103 
     104         ENDIF 
     105      ELSE 
     106         IF ( l_vremap ) THEN 
     107            tabres_child(:,:,:,:) = 0._wp 
     108            AGRIF_SpecialValue = 0._wp 
    89109            DO jj=j1,j2 
    90110               DO ji=i1,i2 
    91                   tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) & 
    92                                            + (tmask(ji,jj,jk)-1)*999._wp 
    93                END DO 
    94             END DO 
    95          END DO 
    96       ELSE 
    97          tabres_child(:,:,:,:) = 0. 
    98          AGRIF_SpecialValue = 0._wp 
    99          DO jj=j1,j2 
    100             DO ji=i1,i2 
    101                N_in = 0 
    102                DO jk=k1,k2 !k2 = jpk of child grid 
    103                   IF (tabres(ji,jj,jk,n2) == 0  ) EXIT 
    104                   N_in = N_in + 1 
    105                   tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 
    106                   h_in(N_in) = tabres(ji,jj,jk,n2) 
     111                  N_in = 0 
     112                  DO jk=k1,k2 !k2 = jpk of child grid 
     113                     IF (tabres(ji,jj,jk,n2) <= 1.e-6_wp  ) EXIT 
     114                     N_in = N_in + 1 
     115                     tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 
     116                     h_in(N_in) = tabres(ji,jj,jk,n2) 
     117                  ENDDO 
     118                  N_out = 0 
     119                  DO jk=1,jpk ! jpk of parent grid 
     120                     IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF 
     121                     N_out = N_out + 1 
     122                     h_out(N_out) = e3t(ji,jj,jk,Kmm_a) 
     123                  ENDDO 
     124                  IF (N_in*N_out > 0) THEN !Remove this? 
     125                     CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra) 
     126                  ENDIF 
    107127               ENDDO 
    108                N_out = 0 
    109                DO jk=1,jpk ! jpk of parent grid 
    110                   IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF 
    111                   N_out = N_out + 1 
    112                   h_out(N_out) = e3t(ji,jj,jk,Kmm_a) !Parent grid scale factors. Could multiply by e1e2t here instead of division above 
    113                ENDDO 
    114                IF (N_in > 0) THEN !Remove this? 
    115                   h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
    116                   IF (h_diff < -1.e-4) THEN 
    117                      print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out)) 
    118                      print *,h_in(1:N_in) 
    119                      print *,h_out(1:N_out) 
    120                      STOP 
    121                   ENDIF 
    122                   CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra) 
    123                ENDIF 
    124128            ENDDO 
    125          ENDDO 
    126          ! 
    127          IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 
    128             ! Add asselin part 
    129             DO jn = 1,jptra 
    130                DO jk=1,jpkm1 
     129 
     130            IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 
     131               ! Add asselin part 
     132               DO jn = 1,jptra 
     133                  DO jk = 1, jpkm1 
     134                     DO jj = j1, j2 
     135                        DO ji = i1, i2 
     136                           IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 
     137                              ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
     138                              ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 
     139                              ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
     140                              tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) )  & 
     141                                        &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
     142                           ENDIF 
     143                        END DO 
     144                     END DO 
     145                  END DO 
     146               END DO 
     147            ENDIF 
     148            DO jn = 1,jptra 
     149               DO jk = 1, jpkm1 
     150                  DO jj = j1, j2 
     151                     DO ji = i1, i2 
     152                        IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 
     153                           tr(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 
     154                        END IF 
     155                     END DO 
     156                  END DO 
     157               END DO 
     158            END DO 
     159         ELSE 
     160            DO jn = 1,jptra 
     161               tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 
     162                                            & * tmask(i1:i2,j1:j2,k1:k2) 
     163            ENDDO 
     164            IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 
     165               ! Add asselin part 
     166               DO jn = 1,jptra 
     167                  DO jk = k1, k2 
     168                     DO jj = j1, j2 
     169                        DO ji = i1, i2 
     170                           IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 
     171                              ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
     172                              ztnu = tabres(ji,jj,jk,jn) 
     173                              ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
     174                              tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) )  & 
     175                                        &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
     176                           ENDIF 
     177                        END DO 
     178                     END DO 
     179                  END DO 
     180               END DO 
     181            ENDIF 
     182            DO jn = 1,jptra 
     183               DO jk=k1,k2 
    131184                  DO jj=j1,j2 
    132185                     DO ji=i1,i2 
    133                         IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 
    134                            ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
    135                            ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 
    136                            ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
    137                            tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) )  &  
    138                                      &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
    139                         ENDIF 
    140                      ENDDO 
    141                   ENDDO 
    142                ENDDO 
    143             ENDDO 
     186                        IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 
     187                           tr(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a) 
     188                        END IF 
     189                     END DO 
     190                  END DO 
     191               END DO 
     192            END DO 
     193            ! 
    144194         ENDIF 
    145          DO jn = 1,jptra 
    146             DO jk=1,jpkm1 
    147                DO jj=j1,j2 
    148                   DO ji=i1,i2 
    149                      IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN  
    150                         tr(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 
    151                      END IF 
    152                   END DO 
    153                END DO 
    154             END DO 
    155          END DO 
    156          ! 
    157195         IF  ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 
    158196            tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kbb_a)  = tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kmm_a) 
    159197         ENDIF 
    160          ! 
    161  
    162198      ENDIF 
    163       !  
     199      ! 
    164200   END SUBROUTINE updateTRC 
    165  
    166  
    167 #else 
    168    SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    169       !!---------------------------------------------------------------------- 
    170       !!                      *** ROUTINE updateTRC *** 
    171       !!---------------------------------------------------------------------- 
    172       INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2 
    173       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres 
    174       LOGICAL                                    , INTENT(in   ) ::   before 
    175       !! 
    176       INTEGER :: ji,jj,jk,jn 
    177       REAL(wp) :: ztb, ztnu, ztno 
    178       !!---------------------------------------------------------------------- 
    179       ! 
    180       ! 
    181       IF (before) THEN 
    182          DO jn = n1,n2 
    183             DO jk=k1,k2 
    184                DO jj=j1,j2 
    185                   DO ji=i1,i2 
    186 !> jc tmp 
    187                      tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk) 
    188 !                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) 
    189 !< jc tmp 
    190                   END DO 
    191                END DO 
    192             END DO 
    193          END DO 
    194       ELSE 
    195 !> jc tmp 
    196          DO jn = n1,n2 
    197             tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 
    198                                          & * tmask(i1:i2,j1:j2,k1:k2) 
    199          ENDDO 
    200 !< jc tmp 
    201          IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 
    202             ! Add asselin part 
    203             DO jn = n1,n2 
    204                DO jk=k1,k2 
    205                   DO jj=j1,j2 
    206                      DO ji=i1,i2 
    207                         IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    208                            ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
    209                            ztnu = tabres(ji,jj,jk,jn) 
    210                            ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
    211                            tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) )  &  
    212                                      &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
    213                         ENDIF 
    214                      ENDDO 
    215                   ENDDO 
    216                ENDDO 
    217             ENDDO 
    218          ENDIF 
    219          DO jn = n1,n2 
    220             DO jk=k1,k2 
    221                DO jj=j1,j2 
    222                   DO ji=i1,i2 
    223                      IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN  
    224                         tr(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a) 
    225                      END IF 
    226                   END DO 
    227                END DO 
    228             END DO 
    229          END DO 
    230          ! 
    231          IF  ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 
    232             tr(i1:i2,j1:j2,k1:k2,n1:n2,Kbb_a)  = tr(i1:i2,j1:j2,k1:k2,n1:n2,Kmm_a) 
    233          ENDIF 
    234          ! 
    235       ENDIF 
    236       !  
    237    END SUBROUTINE updateTRC 
    238 #endif 
    239201 
    240202#else 
Note: See TracChangeset for help on using the changeset viewer.