- Timestamp:
- 2017-12-14T11:10:02+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_merge_2017/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90
r9019 r9031 26 26 PUBLIC Agrif_Update_Trc 27 27 28 INTEGER, PUBLIC :: nbcline_trc = 0 !: ???29 30 28 !!---------------------------------------------------------------------- 31 29 !! NEMO/NST 4.0 , NEMO Consortium (2017) … … 35 33 CONTAINS 36 34 37 SUBROUTINE Agrif_Update_Trc( kt)35 SUBROUTINE Agrif_Update_Trc( ) 38 36 !!---------------------------------------------------------------------- 39 37 !! *** ROUTINE Agrif_Update_Trc *** 40 38 !!---------------------------------------------------------------------- 41 INTEGER, INTENT(in) :: kt 42 !!---------------------------------------------------------------------- 43 ! 44 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 39 ! 40 IF (Agrif_Root()) RETURN 41 ! 45 42 #if defined TWO_WAY 46 43 Agrif_UseSpecialValueInUpdate = .TRUE. 47 44 Agrif_SpecialValueFineGrid = 0._wp 48 45 ! 49 IF( MOD(nbcline_trc,nbclineupdate) == 0 ) THEN50 46 # if ! defined DECAL_FEEDBACK 51 CALL Agrif_Update_Variable(trn_id, procname=updateTRC ) 47 CALL Agrif_Update_Variable(trn_id, procname=updateTRC ) 48 ! CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC ) 52 49 # else 53 CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC ) 50 CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC ) 51 ! CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC ) 54 52 # endif 53 ! 54 Agrif_UseSpecialValueInUpdate = .FALSE. 55 ! 56 #endif 57 ! 58 END SUBROUTINE Agrif_Update_Trc 59 60 #ifdef key_vertical 61 SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 62 !!--------------------------------------------- 63 !! *** ROUTINE updateT *** 64 !!--------------------------------------------- 65 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 66 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 67 LOGICAL, INTENT(in) :: before 68 !! 69 INTEGER :: ji,jj,jk,jn 70 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child 71 REAL(wp) :: h_in(k1:k2) 72 REAL(wp) :: h_out(1:jpk) 73 INTEGER :: N_in, N_out 74 REAL(wp) :: h_diff 75 REAL(wp) :: zrho_xy 76 REAL(wp) :: tabin(k1:k2,n1:n2) 77 !!--------------------------------------------- 78 ! 79 IF (before) THEN 80 AGRIF_SpecialValue = -999._wp 81 zrho_xy = Agrif_rhox() * Agrif_rhoy() 82 DO jn = n1,n2-1 83 DO jk=k1,k2 84 DO jj=j1,j2 85 DO ji=i1,i2 86 tabres(ji,jj,jk,jn) = (trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & 87 * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp 88 END DO 89 END DO 90 END DO 91 END DO 92 DO jk=k1,k2 93 DO jj=j1,j2 94 DO ji=i1,i2 95 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & 96 + (tmask(ji,jj,jk)-1)*999._wp 97 END DO 98 END DO 99 END DO 55 100 ELSE 56 # if ! defined DECAL_FEEDBACK 57 CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC ) 58 # else 59 CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC ) 60 # endif 101 tabres_child(:,:,:,:) = 0. 102 AGRIF_SpecialValue = 0._wp 103 DO jj=j1,j2 104 DO ji=i1,i2 105 N_in = 0 106 DO jk=k1,k2 !k2 = jpk of child grid 107 IF (tabres(ji,jj,jk,n2) == 0 ) EXIT 108 N_in = N_in + 1 109 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 110 h_in(N_in) = tabres(ji,jj,jk,n2) 111 ENDDO 112 N_out = 0 113 DO jk=1,jpk ! jpk of parent grid 114 IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF 115 N_out = N_out + 1 116 h_out(N_out) = e3t_n(ji,jj,jk) !Parent grid scale factors. Could multiply by e1e2t here instead of division above 117 ENDDO 118 IF (N_in > 0) THEN !Remove this? 119 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 120 IF (h_diff < -1.e-4) THEN 121 print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out)) 122 print *,h_in(1:N_in) 123 print *,h_out(1:N_out) 124 STOP 125 ENDIF 126 DO jn=1,jptra 127 CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out) 128 ENDDO 129 ENDIF 130 ENDDO 131 ENDDO 132 133 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 134 ! Add asselin part 135 DO jn = 1,jptra 136 DO jk=1,jpk 137 DO jj=j1,j2 138 DO ji=i1,i2 139 IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 140 trb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 141 & + atfp * ( tabres_child(ji,jj,jk,jn) & 142 & - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 143 ENDIF 144 ENDDO 145 ENDDO 146 ENDDO 147 ENDDO 148 ENDIF 149 DO jn = 1,jptra 150 DO jk=1,jpk 151 DO jj=j1,j2 152 DO ji=i1,i2 153 IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 154 trn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk) 155 END IF 156 END DO 157 END DO 158 END DO 159 END DO 61 160 ENDIF 62 ! 63 Agrif_UseSpecialValueInUpdate = .FALSE. 64 nbcline_trc = nbcline_trc + 1 65 #endif 66 ! 67 END SUBROUTINE Agrif_Update_Trc 68 69 70 SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 71 !!---------------------------------------------------------------------- 72 !! *** ROUTINE updateT *** 161 ! 162 END SUBROUTINE updateTRC 163 164 165 #else 166 SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 167 !!---------------------------------------------------------------------- 168 !! *** ROUTINE updateTRC *** 73 169 !!---------------------------------------------------------------------- 74 170 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 75 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab171 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 76 172 LOGICAL , INTENT(in ) :: before 77 173 !! 78 INTEGER :: ji, jj, jk, jn 79 !!---------------------------------------------------------------------- 80 ! 81 IF( before ) THEN 82 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 174 INTEGER :: ji,jj,jk,jn 175 REAL(wp) :: ztb, ztnu, ztno 176 !!---------------------------------------------------------------------- 177 ! 178 ! 179 IF (before) THEN 180 DO jn = n1,n2 181 DO jk=k1,k2 182 DO jj=j1,j2 183 DO ji=i1,i2 184 !> jc tmp 185 tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk) 186 ! tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) 187 !< jc tmp 188 END DO 189 END DO 190 END DO 191 END DO 83 192 ELSE 84 IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN 193 !> jc tmp 194 DO jn = n1,n2 195 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 196 & * tmask(i1:i2,j1:j2,k1:k2) 197 ENDDO 198 !< jc tmp 199 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 85 200 ! Add asselin part 86 201 DO jn = n1,n2 87 DO jk = k1, k2 88 DO jj = j1, j2 89 DO ji = i1, i2 90 IF( ptab(ji,jj,jk,jn) /= 0._wp ) THEN 91 trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & 92 & + atfp * ( ptab(ji,jj,jk,jn) & 93 & - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 202 DO jk=k1,k2 203 DO jj=j1,j2 204 DO ji=i1,i2 205 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 206 ztb = trb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used 207 ztnu = tabres(ji,jj,jk,jn) 208 ztno = trn(ji,jj,jk,jn) * e3t_a(ji,jj,jk) 209 trb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) ) & 210 & * tmask(ji,jj,jk) / e3t_b(ji,jj,jk) 94 211 ENDIF 95 END 96 END 97 END 98 END 212 ENDDO 213 ENDDO 214 ENDDO 215 ENDDO 99 216 ENDIF 100 DO jn = n1, 101 DO jk = k1,k2102 DO jj = j1,j2103 DO ji = i1,i2104 IF( ptab(ji,jj,jk,jn) /= 0._wp) THEN105 trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk)217 DO jn = n1,n2 218 DO jk=k1,k2 219 DO jj=j1,j2 220 DO ji=i1,i2 221 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 222 trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk) 106 223 END IF 107 224 END DO … … 109 226 END DO 110 227 END DO 228 ! 229 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 230 trb(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 231 ENDIF 232 ! 111 233 ENDIF 112 234 ! 113 235 END SUBROUTINE updateTRC 236 #endif 114 237 115 238 #else
Note: See TracChangeset
for help on using the changeset viewer.
