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.
agrif_top_update.F90 in NEMO/trunk/src/NST – NEMO

source: NEMO/trunk/src/NST/agrif_top_update.F90 @ 14109

Last change on this file since 14109 was 14086, checked in by cetlod, 4 years ago

Adding AGRIF branches into the trunk
  • Property svn:keywords set to Id
File size: 8.1 KB
RevLine 
[5656]1#undef DECAL_FEEDBACK
[628]2
[636]3MODULE agrif_top_update
[6140]4   !!======================================================================
5   !!                ***  MODULE agrif_top_update  ***
[9019]6   !! AGRIF :   update package for passive tracers (TOP)
7   !!======================================================================
[6140]8   !! History : 
9   !!----------------------------------------------------------------------
[1206]10#if defined key_agrif && defined key_top
[9019]11   !!----------------------------------------------------------------------
12   !!   'key_agrif'                                              AGRIF zoom
13   !!   'key_TOP'                                           on-line tracers
14   !!----------------------------------------------------------------------
[636]15   USE par_oce
16   USE oce
[9019]17   USE dom_oce
18   USE agrif_oce
[6140]19   USE par_trc
20   USE trc
[12377]21   USE vremap
[628]22
[636]23   IMPLICIT NONE
24   PRIVATE
[628]25
[636]26   PUBLIC Agrif_Update_Trc
[628]27
[1156]28   !!----------------------------------------------------------------------
[9598]29   !! NEMO/NST 4.0 , NEMO Consortium (2018)
[1156]30   !! $Id$
[10068]31   !! Software governed by the CeCILL license (see ./LICENSE)
[1156]32   !!----------------------------------------------------------------------
[5656]33CONTAINS
[636]34
[9031]35   SUBROUTINE Agrif_Update_Trc( )
[6140]36      !!----------------------------------------------------------------------
37      !!                   *** ROUTINE Agrif_Update_Trc ***
38      !!----------------------------------------------------------------------
[5656]39      !
[9031]40      IF (Agrif_Root()) RETURN 
41      !
[14086]42      l_vremap                      = ln_vert_remap
43      Agrif_UseSpecialValueInUpdate = .NOT.l_vremap
[6140]44      Agrif_SpecialValueFineGrid    = 0._wp
[14086]45
[5656]46      !
47# if ! defined DECAL_FEEDBACK
[9031]48      CALL Agrif_Update_Variable(trn_id, procname=updateTRC )
49!      CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC )
[5656]50# else
[9031]51      CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC )
52!      CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC )
[5656]53# endif
54      !
[628]55      Agrif_UseSpecialValueInUpdate = .FALSE.
[14086]56      l_vremap                      = .FALSE.
[9031]57      !
[636]58   END SUBROUTINE Agrif_Update_Trc
[628]59
[9031]60   SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
[14086]61
[9031]62      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
63      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
64      LOGICAL, INTENT(in) :: before
65      !!
66      INTEGER :: ji,jj,jk,jn
[12377]67      REAL(wp) :: ztb, ztnu, ztno
[9031]68      REAL(wp) :: h_in(k1:k2)
69      REAL(wp) :: h_out(1:jpk)
70      INTEGER  :: N_in, N_out
71      REAL(wp) :: h_diff
[12377]72      REAL(wp) :: tabin(k1:k2,1:jptra)
73      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: tabres_child
[14086]74
[9031]75      IF (before) THEN
[14086]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
[9031]86            DO jk=k1,k2
87               DO jj=j1,j2
88                  DO ji=i1,i2
[14086]89                     tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
[9031]90                  END DO
91               END DO
92            END DO
[14086]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
[9031]101               END DO
102            END DO
[14086]103
104         ENDIF
[9031]105      ELSE
[14086]106         IF ( l_vremap ) THEN
107            tabres_child(:,:,:,:) = 0._wp
108            AGRIF_SpecialValue = 0._wp
109            DO jj=j1,j2
110               DO ji=i1,i2
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)
[9031]126                  ENDIF
127               ENDDO
128            ENDDO
[14086]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
[9031]145                  END DO
146               END DO
[14086]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
[9031]158            END DO
[14086]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
[9031]179                  END DO
180               END DO
[14086]181            ENDIF
182            DO jn = 1,jptra
[9031]183               DO jk=k1,k2
184                  DO jj=j1,j2
185                     DO ji=i1,i2
[14086]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
[5656]190                  END DO
191               END DO
192            END DO
[14086]193            !
194         ENDIF
[12489]195         IF  ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN
[14086]196            tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kbb_a)  = tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kmm_a)
[9031]197         ENDIF
[5656]198      ENDIF
[14086]199      !
[636]200   END SUBROUTINE updateTRC
[628]201
202#else
[9019]203   !!----------------------------------------------------------------------
204   !!   Empty module                                           no TOP AGRIF
205   !!----------------------------------------------------------------------
[636]206CONTAINS
207   SUBROUTINE agrif_top_update_empty
208      WRITE(*,*)  'agrif_top_update : You should not have seen this print! error?'
209   END SUBROUTINE agrif_top_update_empty
[628]210#endif
[6140]211
212   !!======================================================================
[5656]213END MODULE agrif_top_update
Note: See TracBrowser for help on using the repository browser.