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 trunk/NEMO/NST_SRC – NEMO

source: trunk/NEMO/NST_SRC/agrif_top_interp.F90 @ 1206

Last change on this file since 1206 was 1206, checked in by rblod, 16 years ago

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