source: branches/NERC/dev_r5107_NOC_MEDUSA/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90 @ 5706

Last change on this file since 5706 was 3680, checked in by rblod, 9 years ago

First commit of the final branch for 2012 (future nemo_3_5), see ticket #1028

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