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 branches/UKMO/dev_r5518_medusa_fix_restart/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/UKMO/dev_r5518_medusa_fix_restart/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90 @ 7850

Last change on this file since 7850 was 7850, checked in by marc, 7 years ago

Removing the SVN keywords

File size: 3.6 KB
Line 
1#define TWO_WAY
2
3MODULE agrif_top_update
4
5#if defined key_agrif && defined key_top
6   USE par_oce
7   USE oce
8   USE dom_oce
9   USE agrif_oce
10   USE trc
11   USE wrk_nemo 
12
13   IMPLICIT NONE
14   PRIVATE
15
16   PUBLIC Agrif_Update_Trc
17
18   INTEGER, PUBLIC :: nbcline_trc = 0
19
20   !!----------------------------------------------------------------------
21   !! NEMO/NST 3.3 , NEMO Consortium (2010)
22   !! $Id$
23   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
24   !!----------------------------------------------------------------------
25
26   CONTAINS
27
28   SUBROUTINE Agrif_Update_Trc( kt )
29      !!---------------------------------------------
30      !!   *** ROUTINE Agrif_Update_Trc ***
31      !!---------------------------------------------
32      !!
33      INTEGER, INTENT(in) :: kt
34      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra
35
36 
37      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN
38
39#if defined TWO_WAY
40      CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra )
41
42      Agrif_UseSpecialValueInUpdate = .TRUE.
43      Agrif_SpecialValueFineGrid = 0.
44 
45     IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN
46         CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC)
47      ELSE
48         CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC)
49      ENDIF
50
51      Agrif_UseSpecialValueInUpdate = .FALSE.
52      nbcline_trc = nbcline_trc + 1
53
54      CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra )
55#endif
56
57   END SUBROUTINE Agrif_Update_Trc
58
59   SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before)
60      !!---------------------------------------------
61      !!   *** ROUTINE UpdateTrc ***
62      !!---------------------------------------------
63      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
64      REAL, DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
65      LOGICAL, INTENT(in) :: before
66   
67      INTEGER :: ji,jj,jk,jn
68
69         IF( before ) THEN
70            DO jn = n1, n2
71               DO jk = k1, k2
72                  DO jj = j1, j2
73                     DO ji = i1, i2
74                        tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn)
75                     ENDDO
76                  ENDDO
77               ENDDO
78            ENDDO
79         ELSE
80            IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
81            ! Add asselin part
82               DO jn = n1, n2
83                  DO jk = k1, k2
84                     DO jj = j1, j2
85                        DO ji = i1, i2
86                           IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
87                              trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & 
88                                 & + atfp * ( tabres(ji,jj,jk,jn) &
89                                               - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
90                           ENDIF
91                        ENDDO
92                     ENDDO
93                  ENDDO
94               ENDDO
95            ENDIF
96
97            DO jn = n1, n2
98               DO jk = k1, k2
99                  DO jj = j1, j2
100                     DO ji = i1, i2
101                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
102                           trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
103                        ENDIF
104                     ENDDO
105                  ENDDO
106               ENDDO
107            ENDDO
108         ENDIF
109
110   END SUBROUTINE updateTRC
111
112#else
113CONTAINS
114   SUBROUTINE agrif_top_update_empty
115      !!---------------------------------------------
116      !!   *** ROUTINE agrif_Top_update_empty ***
117      !!---------------------------------------------
118      WRITE(*,*)  'agrif_top_update : You should not have seen this print! error?'
119   END SUBROUTINE agrif_top_update_empty
120#endif
121END Module agrif_top_update
Note: See TracBrowser for help on using the repository browser.