Changeset 2977 for branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC
- Timestamp:
- 2011-10-22T15:46:41+02:00 (13 years ago)
- Location:
- branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r2715 r2977 35 35 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spe1ur2, spe2vr2, spbtr3 !: ??? 36 36 37 INTEGER :: t n_id, sn_id, tb_id, sb_id, ta_id,sa_id37 INTEGER :: tsn_id,tsb_id,tsa_id 38 38 INTEGER :: un_id, vn_id, ua_id, va_id 39 39 INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id -
branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r2715 r2977 48 48 !!---------------------------------------------------------------------- 49 49 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 50 USE wrk_nemo, ONLY: wrk_ 3d_1, wrk_3d_250 USE wrk_nemo, ONLY: wrk_4d_1 51 51 !! 52 INTEGER :: ji, jj, jk ! dummy loop indices52 INTEGER :: ji, jj, jk, jn ! dummy loop indices 53 53 REAL(wp) :: zrhox , alpha1, alpha2, alpha3 54 54 REAL(wp) :: alpha4, alpha5, alpha6, alpha7 55 REAL(wp), POINTER, DIMENSION(:,:,: ) :: zta, zsa55 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 56 56 !!---------------------------------------------------------------------- 57 57 ! 58 58 IF( Agrif_Root() ) RETURN 59 59 60 zt a => wrk_3d_1 ; zsa => wrk_3d_261 IF( wrk_in_use( 3, 1,2) )THEN60 ztsa => wrk_4d_1 61 IF( wrk_in_use(4, 1) )THEN 62 62 CALL ctl_stop('agrif_tra: requested workspace arrays unavailable.') 63 63 RETURN … … 66 66 Agrif_SpecialValue = 0.e0 67 67 Agrif_UseSpecialValue = .TRUE. 68 zta(:,:,:) = 0.e0 69 zsa(:,:,:) = 0.e0 70 71 CALL Agrif_Bc_variable( zta, tn_id, procname = interptn ) 72 CALL Agrif_Bc_variable( zsa, sn_id, procname = interpsn ) 68 ztsa(:,:,:,:) = 0.e0 69 70 CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 73 71 Agrif_UseSpecialValue = .FALSE. 74 72 … … 87 85 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 88 86 89 ta(nlci,:,:) = alpha1 * zta(nlci,:,:) + alpha2 * zta(nlci-1,:,:) 90 sa(nlci,:,:) = alpha1 * zsa(nlci,:,:) + alpha2 * zsa(nlci-1,:,:) 91 92 DO jk = 1, jpkm1 93 DO jj = 1, jpj 94 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 95 ta(nlci-1,jj,jk) = ta(nlci,jj,jk) * tmask(nlci-1,jj,jk) 96 sa(nlci-1,jj,jk) = sa(nlci,jj,jk) * tmask(nlci-1,jj,jk) 97 ELSE 98 ta(nlci-1,jj,jk)=(alpha4*ta(nlci,jj,jk)+alpha3*ta(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 99 sa(nlci-1,jj,jk)=(alpha4*sa(nlci,jj,jk)+alpha3*sa(nlci-2,jj,jk))*tmask(nlci-1,jj,jk) 100 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 101 ta(nlci-1,jj,jk)=( alpha6*ta(nlci-2,jj,jk)+alpha5*ta(nlci,jj,jk) & 102 & + alpha7*ta(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 103 sa(nlci-1,jj,jk)=( alpha6*sa(nlci-2,jj,jk)+alpha5*sa(nlci,jj,jk) & 104 & + alpha7*sa(nlci-3,jj,jk) ) * tmask(nlci-1,jj,jk) 87 DO jn = 1, jpts 88 tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn) 89 DO jk = 1, jpkm1 90 DO jj = 1, jpj 91 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 92 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 93 ELSE 94 tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 95 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 96 tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn) & 97 & + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 98 ENDIF 105 99 ENDIF 106 END IF107 END DO 108 END 100 END DO 101 END DO 102 ENDDO 109 103 ENDIF 110 104 111 105 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 112 106 113 ta(:,nlcj,:) = alpha1 * zta(:,nlcj,:) + alpha2 * zta(:,nlcj-1,:) 114 sa(:,nlcj,:) = alpha1 * zsa(:,nlcj,:) + alpha2 * zsa(:,nlcj-1,:) 115 116 DO jk = 1, jpkm1 117 DO ji = 1, jpi 118 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 119 ta(ji,nlcj-1,jk) = ta(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 120 sa(ji,nlcj-1,jk) = sa(ji,nlcj,jk) * tmask(ji,nlcj-1,jk) 121 ELSE 122 ta(ji,nlcj-1,jk)=(alpha4*ta(ji,nlcj,jk)+alpha3*ta(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 123 sa(ji,nlcj-1,jk)=(alpha4*sa(ji,nlcj,jk)+alpha3*sa(ji,nlcj-2,jk))*tmask(ji,nlcj-1,jk) 124 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 125 ta(ji,nlcj-1,jk)=( alpha6*ta(ji,nlcj-2,jk)+alpha5*ta(ji,nlcj,jk) & 126 & + alpha7*ta(ji,nlcj-3,jk) ) * tmask(ji,nlcj-1,jk) 127 sa(ji,nlcj-1,jk)=( alpha6*sa(ji,nlcj-2,jk)+alpha5*sa(ji,nlcj,jk) & 128 & + alpha7*sa(ji,nlcj-3,jk))*tmask(ji,nlcj-1,jk) 107 DO jn = 1, jpts 108 tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn) 109 DO jk = 1, jpkm1 110 DO ji = 1, jpi 111 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 112 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 113 ELSE 114 tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 115 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 116 tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn) & 117 & + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 118 ENDIF 129 119 ENDIF 130 END IF131 END DO 132 END DO120 END DO 121 END DO 122 ENDDO 133 123 ENDIF 134 124 135 125 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 136 ta(1,:,:) = alpha1 * zta(1,:,:) + alpha2 * zta(2,:,:) 137 sa(1,:,:) = alpha1 * zsa(1,:,:) + alpha2 * zsa(2,:,:) 138 DO jk = 1, jpkm1 139 DO jj = 1, jpj 140 IF( umask(2,jj,jk) == 0.e0 ) THEN 141 ta(2,jj,jk) = ta(1,jj,jk) * tmask(2,jj,jk) 142 sa(2,jj,jk) = sa(1,jj,jk) * tmask(2,jj,jk) 143 ELSE 144 ta(2,jj,jk)=(alpha4*ta(1,jj,jk)+alpha3*ta(3,jj,jk))*tmask(2,jj,jk) 145 sa(2,jj,jk)=(alpha4*sa(1,jj,jk)+alpha3*sa(3,jj,jk))*tmask(2,jj,jk) 146 IF( un(2,jj,jk) < 0.e0 ) THEN 147 ta(2,jj,jk)=(alpha6*ta(3,jj,jk)+alpha5*ta(1,jj,jk)+alpha7*ta(4,jj,jk))*tmask(2,jj,jk) 148 sa(2,jj,jk)=(alpha6*sa(3,jj,jk)+alpha5*sa(1,jj,jk)+alpha7*sa(4,jj,jk))*tmask(2,jj,jk) 126 DO jn = 1, jpts 127 tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 128 DO jk = 1, jpkm1 129 DO jj = 1, jpj 130 IF( umask(2,jj,jk) == 0.e0 ) THEN 131 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 132 ELSE 133 tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 134 IF( un(2,jj,jk) < 0.e0 ) THEN 135 tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 136 ENDIF 149 137 ENDIF 150 END IF138 END DO 151 139 END DO 152 140 END DO … … 154 142 155 143 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 156 ta(:,1,:) = alpha1 * zta(:,1,:) + alpha2 * zta(:,2,:) 157 sa(:,1,:) = alpha1 * zsa(:,1,:) + alpha2 * zsa(:,2,:) 158 DO jk=1,jpk 159 DO ji=1,jpi 160 IF( vmask(ji,2,jk) == 0.e0 ) THEN 161 ta(ji,2,jk)=ta(ji,1,jk) * tmask(ji,2,jk) 162 sa(ji,2,jk)=sa(ji,1,jk) * tmask(ji,2,jk) 163 ELSE 164 ta(ji,2,jk)=(alpha4*ta(ji,1,jk)+alpha3*ta(ji,3,jk))*tmask(ji,2,jk) 165 sa(ji,2,jk)=(alpha4*sa(ji,1,jk)+alpha3*sa(ji,3,jk))*tmask(ji,2,jk) 166 IF( vn(ji,2,jk) < 0.e0 ) THEN 167 ta(ji,2,jk)=(alpha6*ta(ji,3,jk)+alpha5*ta(ji,1,jk)+alpha7*ta(ji,4,jk))*tmask(ji,2,jk) 168 sa(ji,2,jk)=(alpha6*sa(ji,3,jk)+alpha5*sa(ji,1,jk)+alpha7*sa(ji,4,jk))*tmask(ji,2,jk) 144 DO jn = 1, jpts 145 tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn) 146 DO jk=1,jpk 147 DO ji=1,jpi 148 IF( vmask(ji,2,jk) == 0.e0 ) THEN 149 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 150 ELSE 151 tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 152 IF( vn(ji,2,jk) < 0.e0 ) THEN 153 tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 154 ENDIF 169 155 ENDIF 170 END IF171 END DO 172 END 156 END DO 157 END DO 158 ENDDO 173 159 ENDIF 174 160 ! 175 IF( wrk_not_released( 3, 1,2) ) THEN161 IF( wrk_not_released(4, 1) ) THEN 176 162 CALL ctl_stop('agrif_tra: failed to release workspace arrays.') 177 163 ENDIF -
branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r2715 r2977 12 12 PRIVATE 13 13 14 PUBLIC Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interpt n, interpsn, interpun, interpvn14 PUBLIC Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 15 15 16 16 !!---------------------------------------------------------------------- … … 28 28 #include "domzgr_substitute.h90" 29 29 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 30 USE wrk_nemo, ONLY: wrk_2d_1 31 USE wrk_nemo, ONLY: wrk_3d_1, wrk_3d_2 32 USE wrk_nemo, ONLY: wrk_3d_3, wrk_3d_4 33 USE wrk_nemo, ONLY: wrk_3d_7, wrk_3d_6 34 USE wrk_nemo, ONLY: wrk_3d_8 30 USE wrk_nemo, ONLY: wrk_2d_1, wrk_2d_2, wrk_2d_3 31 USE wrk_nemo, ONLY: wrk_4d_1, wrk_4d_2 35 32 !! 36 INTEGER :: ji,jj,jk 33 INTEGER :: ji,jj,jk,jn 37 34 INTEGER :: spongearea 38 35 REAL(wp) :: timecoeff 39 REAL(wp) :: zt a, zsa, zabe1, zabe2, zbtr40 REAL(wp), POINTER, DIMENSION(:,: ) :: localviscsponge41 REAL(wp), POINTER, DIMENSION(:,: ,:) :: tbdiff, sbdiff42 REAL(wp), POINTER, DIMENSION(:,:,: ) :: ztu, zsu, ztv, zsv43 REAL(wp), POINTER, DIMENSION(:,:,: ) :: ztab36 REAL(wp) :: ztsa, zabe1, zabe2, zbtr 37 REAL(wp), POINTER, DIMENSION(:,: ) :: localviscsponge 38 REAL(wp), POINTER, DIMENSION(:,: ) :: ztu, ztv 39 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 40 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff 44 41 45 42 #if defined SPONGE 46 43 localviscsponge => wrk_2d_1 47 tbdiff => wrk_3d_1 ;sbdiff => wrk_3d_248 zt u => wrk_3d_3 ; zsu => wrk_3d_449 zt v => wrk_3d_7 ; zsv => wrk_3d_650 ztab => wrk_3d_844 ztu => wrk_2d_2 45 ztv => wrk_2d_3 46 ztab => wrk_4d_1 47 tsbdiff => wrk_4d_2 51 48 52 49 timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() … … 55 52 Agrif_UseSpecialValue = .TRUE. 56 53 ztab = 0.e0 57 CALL Agrif_Bc_Variable(ztab, t a_id,calledweight=timecoeff,procname=interptn)54 CALL Agrif_Bc_Variable(ztab, tsa_id,calledweight=timecoeff,procname=interptsn) 58 55 Agrif_UseSpecialValue = .FALSE. 59 56 60 tbdiff(:,:,:) = tb(:,:,:) - ztab(:,:,:) 61 62 ztab = 0.e0 63 Agrif_SpecialValue=0. 64 Agrif_UseSpecialValue = .TRUE. 65 CALL Agrif_Bc_Variable(ztab, sa_id,calledweight=timecoeff,procname=interpsn) 66 Agrif_UseSpecialValue = .FALSE. 67 68 sbdiff(:,:,:) = sb(:,:,:) - ztab(:,:,:) 57 tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:) 69 58 70 59 spongearea = 2 + 2 * Agrif_irhox() … … 137 126 ENDIF 138 127 139 DO jk = 1, jpkm1 140 DO jj = 1, jpjm1 141 DO ji = 1, jpim1 142 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 143 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 144 ztu(ji,jj,jk) = zabe1 * ( tbdiff(ji+1,jj ,jk) - tbdiff(ji,jj,jk) ) 145 zsu(ji,jj,jk) = zabe1 * ( sbdiff(ji+1,jj ,jk) - sbdiff(ji,jj,jk) ) 146 ztv(ji,jj,jk) = zabe2 * ( tbdiff(ji ,jj+1,jk) - tbdiff(ji,jj,jk) ) 147 zsv(ji,jj,jk) = zabe2 * ( sbdiff(ji ,jj+1,jk) - sbdiff(ji,jj,jk) ) 128 DO jn = 1, jpts 129 DO jk = 1, jpkm1 130 ! 131 DO jj = 1, jpjm1 132 DO ji = 1, jpim1 133 zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 134 zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 135 ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 136 ztv(ji,jj) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 137 ENDDO 148 138 ENDDO 149 ENDDO 150 151 DO jj = 2,jpjm1 152 DO ji = 2,jpim1 153 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 154 ! horizontal diffusive trends 155 zta = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 156 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 157 zsa = zbtr * ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) & 158 & + zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) 159 ! add it to the general tracer trends 160 ta(ji,jj,jk) = (ta(ji,jj,jk) + zta) 161 sa(ji,jj,jk) = (sa(ji,jj,jk) + zsa) 139 140 DO jj = 2, jpjm1 141 DO ji = 2, jpim1 142 zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 143 ! horizontal diffusive trends 144 ztsa = zbtr * ( ztu(ji,jj) - ztu(ji-1,jj ) & 145 & + ztv(ji,jj) - ztv(ji ,jj-1) ) 146 ! add it to the general tracer trends 147 tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 148 END DO 162 149 END DO 163 END DO164 150 ! 151 ENDDO 165 152 ENDDO 166 153 … … 345 332 END SUBROUTINE Agrif_Sponge_dyn 346 333 347 SUBROUTINE interpt n(tabres,i1,i2,j1,j2,k1,k2)348 !!--------------------------------------------- 349 !! *** ROUTINE interpt n ***334 SUBROUTINE interptsn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 335 !!--------------------------------------------- 336 !! *** ROUTINE interptsn *** 350 337 !!--------------------------------------------- 351 338 # include "domzgr_substitute.h90" 352 339 353 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 354 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 355 356 tabres(i1:i2,j1:j2,k1:k2) = tn(i1:i2,j1:j2,k1:k2) 357 358 END SUBROUTINE interptn 359 360 SUBROUTINE interpsn(tabres,i1,i2,j1,j2,k1,k2) 361 !!--------------------------------------------- 362 !! *** ROUTINE interpsn *** 363 !!--------------------------------------------- 364 # include "domzgr_substitute.h90" 365 366 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 367 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 368 369 tabres(i1:i2,j1:j2,k1:k2) = sn(i1:i2,j1:j2,k1:k2) 370 371 END SUBROUTINE interpsn 340 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 341 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 342 343 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 344 345 END SUBROUTINE interptsn 372 346 373 347 SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) -
branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r2715 r2977 30 30 !!--------------------------------------------- 31 31 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 32 USE wrk_nemo, ONLY: wrk_ 3d_132 USE wrk_nemo, ONLY: wrk_4d_1 33 33 !! 34 34 INTEGER, INTENT(in) :: kt 35 REAL(wp), POINTER, DIMENSION(:,:,: ) :: ztab35 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 36 36 37 37 38 38 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 39 39 #if defined TWO_WAY 40 ztab => wrk_3d_1 41 IF( wrk_in_use(3, 1) ) THEN 40 IF( wrk_in_use(4, 1) ) THEN 42 41 CALL ctl_stop('agrif_update_tra: ERROR: requested workspace arrays unavailable') 43 42 RETURN 44 43 END IF 44 ztab => wrk_4d_1 45 45 46 46 Agrif_UseSpecialValueInUpdate = .TRUE. … … 48 48 49 49 IF (MOD(nbcline,nbclineupdate) == 0) THEN 50 CALL Agrif_Update_Variable(ztab,tn_id, procname=updateT) 51 CALL Agrif_Update_Variable(ztab,sn_id, procname=updateS) 52 ELSE 53 CALL Agrif_Update_Variable(ztab,tn_id,locupdate=(/0,2/), procname=updateT) 54 CALL Agrif_Update_Variable(ztab,sn_id,locupdate=(/0,2/), procname=updateS) 50 CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 51 ELSE 52 CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 55 53 ENDIF 56 54 57 55 Agrif_UseSpecialValueInUpdate = .FALSE. 58 56 59 IF( wrk_not_released( 3, 1) ) THEN57 IF( wrk_not_released(4, 1) ) THEN 60 58 CALL ctl_stop('Agrif_Update_Tra: ERROR: failed to release workspace arrays') 61 59 END IF … … 124 122 END SUBROUTINE recompute_diags 125 123 126 SUBROUTINE updateT ( tabres, i1, i2, j1, j2, k1, k2, before )124 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 127 125 !!--------------------------------------------- 128 126 !! *** ROUTINE updateT *** … … 130 128 # include "domzgr_substitute.h90" 131 129 132 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 133 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2 ), INTENT(inout) :: tabres130 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 131 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 134 132 LOGICAL, iNTENT(in) :: before 135 133 136 INTEGER :: ji,jj,jk 137 138 IF (before) THEN 139 DO jk=k1,k2 140 DO jj=j1,j2 141 DO ji=i1,i2 142 tabres(ji,jj,jk) = tn(ji,jj,jk) 143 END DO 144 END DO 145 END DO 146 ELSE 147 DO jk=k1,k2 148 DO jj=j1,j2 149 DO ji=i1,i2 150 IF( tabres(ji,jj,jk) .NE. 0. ) THEN 151 tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 152 ENDIF 153 END DO 154 END DO 155 END DO 156 ENDIF 157 158 END SUBROUTINE updateT 159 160 SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before ) 161 !!--------------------------------------------- 162 !! *** ROUTINE updateS *** 163 !!--------------------------------------------- 164 # include "domzgr_substitute.h90" 165 166 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 167 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 168 LOGICAL, iNTENT(in) :: before 169 170 INTEGER :: ji,jj,jk 171 172 IF (before) THEN 173 DO jk=k1,k2 174 DO jj=j1,j2 175 DO ji=i1,i2 176 tabres(ji,jj,jk) = sn(ji,jj,jk) 177 END DO 178 END DO 179 END DO 180 ELSE 181 DO jk=k1,k2 182 DO jj=j1,j2 183 DO ji=i1,i2 184 IF (tabres(ji,jj,jk).NE.0.) THEN 185 sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk) 186 ENDIF 187 END DO 188 END DO 189 END DO 190 ENDIF 191 192 END SUBROUTINE updateS 134 INTEGER :: ji,jj,jk,jn 135 136 IF (before) THEN 137 DO jn = n1,n2 138 DO jk=k1,k2 139 DO jj=j1,j2 140 DO ji=i1,i2 141 tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 142 END DO 143 END DO 144 END DO 145 END DO 146 ELSE 147 DO jn = n1,n2 148 DO jk=k1,k2 149 DO jj=j1,j2 150 DO ji=i1,i2 151 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 152 tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 153 END IF 154 END DO 155 END DO 156 END DO 157 END DO 158 ENDIF 159 160 END SUBROUTINE updateTS 193 161 194 162 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before ) -
branches/2011/dev_LOCEAN_2011/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r2727 r2977 54 54 USE dom_oce 55 55 USE nemogcm 56 #if defined key_tradmp || defined key_esopa57 56 USE tradmp 58 #endif59 57 #if defined key_obc || defined key_esopa 60 58 USE obc_par … … 71 69 72 70 ! Specific fine grid Initializations 73 #if defined key_tradmp || defined key_esopa74 71 ! no tracer damping on fine grids 75 lk_tradmp = .FALSE. 76 #endif 72 ln_tradmp = .FALSE. 77 73 #if defined key_obc || defined key_esopa 78 74 ! no open boundary on fine grids … … 110 106 IMPLICIT NONE 111 107 ! 112 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tabtemp 108 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 109 REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: tabuvtemp 113 110 LOGICAL :: check_namelist 114 111 !!---------------------------------------------------------------------- 115 112 116 ALLOCATE( tabtemp(jpi,jpj,jpk) ) 117 118 113 ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 114 ALLOCATE( tabuvtemp(jpi, jpj, jpk) ) 115 116 119 117 ! 1. Declaration of the type of variable which have to be interpolated 120 118 !--------------------------------------------------------------------- … … 125 123 Agrif_SpecialValue=0. 126 124 Agrif_UseSpecialValue = .TRUE. 127 Call Agrif_Bc_variable(tabtemp,tn_id,calledweight=1.,procname=interptn) 128 129 Call Agrif_Bc_variable(tabtemp,sn_id,calledweight=1.,procname=interpsn) 130 Call Agrif_Bc_variable(tabtemp,un_id,calledweight=1.,procname=interpu) 131 Call Agrif_Bc_variable(tabtemp,vn_id,calledweight=1.,procname=interpv) 132 133 Call Agrif_Bc_variable(tabtemp,ta_id,calledweight=1.,procname=interptn) 134 Call Agrif_Bc_variable(tabtemp,sa_id,calledweight=1.,procname=interpsn) 135 136 Call Agrif_Bc_variable(tabtemp,ua_id,calledweight=1.,procname=interpun) 137 Call Agrif_Bc_variable(tabtemp,va_id,calledweight=1.,procname=interpvn) 125 Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 126 Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 127 128 Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 129 Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 130 Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 131 Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 138 132 Agrif_UseSpecialValue = .FALSE. 139 133 … … 192 186 nbcline = 0 193 187 ! 194 DEALLOCATE(tabtemp) 188 DEALLOCATE(tabtstemp) 189 DEALLOCATE(tabuvtemp) 195 190 ! 196 191 END SUBROUTINE Agrif_InitValues_cont … … 204 199 !!---------------------------------------------------------------------- 205 200 USE agrif_util 201 USE par_oce ! ONLY : jpts 206 202 USE oce 207 203 IMPLICIT NONE … … 210 206 ! 1. Declaration of the type of variable which have to be interpolated 211 207 !--------------------------------------------------------------------- 212 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),tn_id) 213 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),sn_id) 214 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),tb_id) 215 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),sb_id) 216 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ta_id) 217 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),sa_id) 218 208 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 209 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 210 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 211 219 212 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 220 213 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) … … 230 223 ! 2. Type of interpolation 231 224 !------------------------- 232 CALL Agrif_Set_bcinterp(tn_id,interp=AGRIF_linear) 233 CALL Agrif_Set_bcinterp(sn_id,interp=AGRIF_linear) 234 CALL Agrif_Set_bcinterp(ta_id,interp=AGRIF_linear) 235 CALL Agrif_Set_bcinterp(sa_id,interp=AGRIF_linear) 225 CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 226 CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 236 227 237 228 Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) … … 252 243 Call Agrif_Set_bc(e2v_id,(/0,0/)) 253 244 254 Call Agrif_Set_bc(tn_id,(/0,1/)) 255 Call Agrif_Set_bc(sn_id,(/0,1/)) 256 257 Call Agrif_Set_bc(ta_id,(/-3*Agrif_irhox(),0/)) 258 Call Agrif_Set_bc(sa_id,(/-3*Agrif_irhox(),0/)) 245 Call Agrif_Set_bc(tsn_id,(/0,1/)) 246 Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 259 247 260 248 Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) … … 263 251 ! 5. Update type 264 252 !--------------- 265 Call Agrif_Set_Updatetype(tn_id, update = AGRIF_Update_Average) 266 Call Agrif_Set_Updatetype(sn_id, update = AGRIF_Update_Average) 267 268 Call Agrif_Set_Updatetype(tb_id, update = AGRIF_Update_Average) 269 Call Agrif_Set_Updatetype(sb_id, update = AGRIF_Update_Average) 253 Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 254 Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 270 255 271 256 Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) … … 395 380 ! 1. Declaration of the type of variable which have to be interpolated 396 381 !--------------------------------------------------------------------- 397 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/), & 398 & (/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 399 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/), & 400 & (/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 401 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0,jptra/),(/'x','y','N','N'/), & 402 & (/1,1,1,1/),(/jpi,jpj,jpk/),tra_id) 403 382 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 383 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 384 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 404 385 # if defined key_offline 405 386 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id)
Note: See TracChangeset
for help on using the changeset viewer.