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_interp.F90 in branches/nemo_v3_3_beta/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 @ 2287

Last change on this file since 2287 was 2287, checked in by smasson, 13 years ago

update licence of all NEMO files...

  • Property svn:keywords set to Id
File size: 4.9 KB
Line 
1MODULE agrif_top_interp
2#if defined key_agrif && defined key_top
3   USE par_oce
4   USE oce
5   USE dom_oce     
6   USE sol_oce
7   USE agrif_oce
8   USE trc
9
10   IMPLICIT NONE
11   PRIVATE
12
13   PUBLIC Agrif_trc
14
15   !!----------------------------------------------------------------------
16   !! NEMO/NST 3.3 , NEMO Consortium (2010)
17   !! $Id$
18   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
19   !!----------------------------------------------------------------------
20
21   CONTAINS
22
23   SUBROUTINE Agrif_trc
24      !!---------------------------------------------
25      !!   *** ROUTINE Agrif_trc ***
26      !!---------------------------------------------
27#  include "domzgr_substitute.h90" 
28#  include "vectopt_loop_substitute.h90"
29     
30      INTEGER :: ji,jj,jk,jn
31      REAL(wp) :: zrhox
32      REAL(wp) :: alpha1, alpha2, alpha3, alpha4
33      REAL(wp) :: alpha5, alpha6, alpha7
34      REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: ztra
35     
36      IF (Agrif_Root()) RETURN
37
38      Agrif_SpecialValue=0.
39      Agrif_UseSpecialValue = .TRUE.
40      ztra = 0.e0
41
42      CALL Agrif_Bc_variable(ztra,trn)
43      Agrif_UseSpecialValue = .FALSE.
44
45      zrhox = Agrif_Rhox()
46
47      alpha1 = (zrhox-1.)/2.
48      alpha2 = 1.-alpha1
49
50      alpha3 = (zrhox-1)/(zrhox+1)
51      alpha4 = 1.-alpha3
52
53      alpha6 = 2.*(zrhox-1.)/(zrhox+1.)
54      alpha7 = -(zrhox-1)/(zrhox+3)
55      alpha5 = 1. - alpha6 - alpha7
56
57      IF ((nbondi == 1).OR.(nbondi == 2)) THEN
58         tra(nlci,:,:,:) = alpha1 * ztra(nlci,:,:,:) + alpha2 * ztra(nlci-1,:,:,:)
59         DO jn=1,jptra 
60            DO jk=1,jpk     
61               DO jj=1,jpj
62                  IF (umask(nlci-2,jj,jk).EQ.0.) THEN
63                     tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
64                  ELSE
65                     tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
66                     IF (un(nlci-2,jj,jk).GT.0.) THEN
67                        tra(nlci-1,jj,jk,jn)=(alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn) &
68                           +alpha7*tra(nlci-3,jj,jk,jn))*tmask(nlci-1,jj,jk)
69                     ENDIF
70                  ENDIF
71               END DO
72            END DO
73         END DO
74      ENDIF
75
76      IF ((nbondj == 1).OR.(nbondj == 2)) THEN
77         tra(:,nlcj,:,:) = alpha1 * ztra(:,nlcj,:,:) + alpha2 * ztra(:,nlcj-1,:,:)
78         DO jn=1, jptra           
79            DO jk=1,jpk     
80               DO ji=1,jpi
81                  IF (vmask(ji,nlcj-2,jk).EQ.0.) THEN
82                     tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
83                  ELSE
84                     tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)       
85                     IF (vn(ji,nlcj-2,jk) .GT. 0.) THEN
86                        tra(ji,nlcj-1,jk,jn)=(alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn) &
87                           +alpha7*tra(ji,nlcj-3,jk,jn))*tmask(ji,nlcj-1,jk)
88                     ENDIF
89                  ENDIF
90               END DO
91            END DO
92         END DO
93      ENDIF
94
95      IF ((nbondi == -1).OR.(nbondi == 2)) THEN
96         tra(1,:,:,:) = alpha1 * ztra(1,:,:,:) + alpha2 * ztra(2,:,:,:)
97         DO jn=1, jptra
98            DO jk=1,jpk     
99               DO jj=1,jpj
100                  IF (umask(2,jj,jk).EQ.0.) THEN
101                     tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk)
102                  ELSE
103                     tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)       
104                     IF (un(2,jj,jk).LT.0.) THEN
105                        tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn) &
106                           +alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk)
107                     ENDIF
108                  ENDIF
109               END DO
110            END DO
111         END DO
112      ENDIF
113
114      IF ((nbondj == -1).OR.(nbondj == 2)) THEN
115         tra(:,1,:,:) = alpha1 * ztra(:,1,:,:) + alpha2 * ztra(:,2,:,:)
116         DO jn=1, jptra 
117            DO jk=1,jpk     
118               DO ji=1,jpi
119                  IF (vmask(ji,2,jk).EQ.0.) THEN
120                     tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk)
121                  ELSE
122                     tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk)
123                     IF (vn(ji,2,jk) .LT. 0.) THEN
124                        tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)&
125                           +alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk)
126                     ENDIF
127                  ENDIF
128               END DO
129            END DO
130         END DO
131      ENDIF
132
133   END SUBROUTINE Agrif_trc
134
135#else
136CONTAINS
137   SUBROUTINE Agrif_TOP_Interp_empty
138      !!---------------------------------------------
139      !!   *** ROUTINE agrif_Top_Interp_empty ***
140      !!---------------------------------------------
141      WRITE(*,*)  'agrif_top_interp : You should not have seen this print! error?'
142   END SUBROUTINE Agrif_TOP_Interp_empty
143#endif
144END MODULE agrif_top_interp
Note: See TracBrowser for help on using the repository browser.