[636] | 1 | MODULE agrif_top_interp |
---|
[1206] | 2 | #if defined key_agrif && defined key_top |
---|
[636] | 3 | USE par_oce |
---|
| 4 | USE oce |
---|
| 5 | USE dom_oce |
---|
| 6 | USE sol_oce |
---|
[782] | 7 | USE agrif_oce |
---|
[2715] | 8 | USE agrif_top_sponge |
---|
[1271] | 9 | USE trc |
---|
[2715] | 10 | USE lib_mpp |
---|
[3294] | 11 | USE wrk_nemo |
---|
[628] | 12 | |
---|
[636] | 13 | IMPLICIT NONE |
---|
| 14 | PRIVATE |
---|
[628] | 15 | |
---|
[636] | 16 | PUBLIC Agrif_trc |
---|
| 17 | |
---|
[2715] | 18 | # include "domzgr_substitute.h90" |
---|
| 19 | # include "vectopt_loop_substitute.h90" |
---|
| 20 | !!---------------------------------------------------------------------- |
---|
[2528] | 21 | !! NEMO/NST 3.3 , NEMO Consortium (2010) |
---|
[1156] | 22 | !! $Id$ |
---|
[2528] | 23 | !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) |
---|
[1156] | 24 | !!---------------------------------------------------------------------- |
---|
| 25 | |
---|
[636] | 26 | CONTAINS |
---|
| 27 | |
---|
[1271] | 28 | SUBROUTINE Agrif_trc |
---|
[3680] | 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 |
---|
[2715] | 36 | REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra |
---|
[3680] | 37 | !!---------------------------------------------------------------------- |
---|
| 38 | ! |
---|
| 39 | IF( Agrif_Root() ) RETURN |
---|
[628] | 40 | |
---|
[3294] | 41 | CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) |
---|
[2715] | 42 | |
---|
[3680] | 43 | Agrif_SpecialValue = 0.e0 |
---|
[636] | 44 | Agrif_UseSpecialValue = .TRUE. |
---|
[3680] | 45 | ztra(:,:,:,:) = 0.e0 |
---|
[628] | 46 | |
---|
[3680] | 47 | CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) |
---|
[636] | 48 | Agrif_UseSpecialValue = .FALSE. |
---|
| 49 | |
---|
| 50 | zrhox = Agrif_Rhox() |
---|
| 51 | |
---|
[3680] | 52 | alpha1 = ( zrhox - 1. ) * 0.5 |
---|
| 53 | alpha2 = 1. - alpha1 |
---|
[636] | 54 | |
---|
[3680] | 55 | alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) |
---|
| 56 | alpha4 = 1. - alpha3 |
---|
[636] | 57 | |
---|
[3680] | 58 | alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) |
---|
| 59 | alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) |
---|
[636] | 60 | alpha5 = 1. - alpha6 - alpha7 |
---|
[3680] | 61 | IF( nbondi == 1 .OR. nbondi == 2 ) THEN |
---|
[636] | 62 | |
---|
[3680] | 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 |
---|
[636] | 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) |
---|
[3680] | 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) |
---|
[636] | 74 | ENDIF |
---|
| 75 | ENDIF |
---|
| 76 | END DO |
---|
| 77 | END DO |
---|
[3680] | 78 | ENDDO |
---|
[628] | 79 | ENDIF |
---|
| 80 | |
---|
[3680] | 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 |
---|
[636] | 88 | tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) |
---|
| 89 | ELSE |
---|
[3680] | 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) |
---|
[636] | 94 | ENDIF |
---|
| 95 | ENDIF |
---|
| 96 | END DO |
---|
| 97 | END DO |
---|
[3680] | 98 | ENDDO |
---|
[636] | 99 | ENDIF |
---|
[3680] | 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 |
---|
[636] | 106 | tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) |
---|
| 107 | ELSE |
---|
[3680] | 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) |
---|
[636] | 111 | ENDIF |
---|
| 112 | ENDIF |
---|
| 113 | END DO |
---|
| 114 | END DO |
---|
| 115 | END DO |
---|
[628] | 116 | ENDIF |
---|
[636] | 117 | |
---|
[3680] | 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 |
---|
[636] | 122 | DO ji=1,jpi |
---|
[3680] | 123 | IF( vmask(ji,2,jk) == 0.e0 ) THEN |
---|
[636] | 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) |
---|
[3680] | 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) |
---|
[636] | 129 | ENDIF |
---|
| 130 | ENDIF |
---|
| 131 | END DO |
---|
| 132 | END DO |
---|
[3680] | 133 | ENDDO |
---|
[628] | 134 | ENDIF |
---|
[3680] | 135 | ! |
---|
[3294] | 136 | CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) |
---|
[3680] | 137 | ! |
---|
[2715] | 138 | |
---|
[636] | 139 | END SUBROUTINE Agrif_trc |
---|
[628] | 140 | |
---|
| 141 | #else |
---|
[636] | 142 | CONTAINS |
---|
| 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 |
---|
[628] | 149 | #endif |
---|
[636] | 150 | END MODULE agrif_top_interp |
---|