Changeset 2024 for branches/DEV_r2006_merge_TRA_TRC
- Timestamp:
- 2010-07-29T12:57:35+02:00 (14 years ago)
- Location:
- branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA
- Files:
-
- 1 added
- 1 deleted
- 24 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv.F90
r1601 r2024 4 4 !! Ocean active tracers: advection trend 5 5 !!============================================================================== 6 !! History : 2.0 ! 05-11 (G. Madec) Original code 6 !! History : 2.0 ! 2005-11 (G. Madec) Original code 7 !! 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport 7 8 !!---------------------------------------------------------------------- 8 9 … … 18 19 USE traadv_muscl2 ! MUSCL2 scheme (tra_adv_muscl2 routine) 19 20 USE traadv_ubs ! UBS scheme (tra_adv_ubs routine) 20 USE traadv_qck !! QUICKEST scheme (tra_adv_qck routine)21 USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine) 21 22 USE traadv_eiv ! eddy induced velocity (tra_adv_eiv routine) 22 USE trabbl ! tracers: bottom boundary layer23 23 USE ldftra_oce ! lateral diffusion coefficient on tracers 24 24 USE in_out_manager ! I/O manager … … 29 29 PRIVATE 30 30 31 PUBLIC tra_adv ! routine called by step module 31 PUBLIC tra_adv ! routine called by step module 32 PUBLIC tra_adv_init ! routine called by opa module 32 33 33 34 ! !!* Namelist namtra_adv * 34 LOGICAL , PUBLIC:: ln_traadv_cen2 = .TRUE. ! 2nd order centered scheme flag35 LOGICAL , PUBLIC:: ln_traadv_tvd = .FALSE. ! TVD scheme flag36 LOGICAL , PUBLIC:: ln_traadv_muscl = .FALSE. ! MUSCL scheme flag37 LOGICAL , PUBLIC:: ln_traadv_muscl2 = .FALSE. ! MUSCL2 scheme flag38 LOGICAL , PUBLIC:: ln_traadv_ubs = .FALSE. ! UBS scheme flag39 LOGICAL , PUBLIC:: ln_traadv_qck = .FALSE. ! QUICKEST scheme flag35 LOGICAL :: ln_traadv_cen2 = .TRUE. ! 2nd order centered scheme flag 36 LOGICAL :: ln_traadv_tvd = .FALSE. ! TVD scheme flag 37 LOGICAL :: ln_traadv_muscl = .FALSE. ! MUSCL scheme flag 38 LOGICAL :: ln_traadv_muscl2 = .FALSE. ! MUSCL2 scheme flag 39 LOGICAL :: ln_traadv_ubs = .FALSE. ! UBS scheme flag 40 LOGICAL :: ln_traadv_qck = .FALSE. ! QUICKEST scheme flag 40 41 41 42 INTEGER :: nadv ! choice of the type of advection scheme … … 60 61 !! ** Method : - Update (ua,va) with the advection term following nadv 61 62 !!---------------------------------------------------------------------- 62 #if ( defined key_trabbl_adv || defined key_traldf_eiv ) 63 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zun, zvn, zwn ! effective velocity 64 #else 65 USE oce, ONLY : zun => un ! the effective velocity is the 66 USE oce, ONLY : zvn => vn ! Eulerian velocity 67 USE oce, ONLY : zwn => wn ! 68 #endif 63 INTEGER, INTENT( in ) :: kt ! ocean time-step index 69 64 !! 70 INTEGER, INTENT( in ) :: kt ! ocean time-step index 71 !!---------------------------------------------------------------------- 72 73 IF( kt == nit000 ) CALL tra_adv_ctl ! initialisation & control of options 74 75 #if defined key_trabbl_adv 76 zun(:,:,:) = un(:,:,:) - u_bbl(:,:,:) ! add the bbl velocity 77 zvn(:,:,:) = vn(:,:,:) - v_bbl(:,:,:) 78 zwn(:,:,:) = wn(:,:,:) + w_bbl(:,:,:) 79 #endif 80 IF( lk_traldf_eiv ) THEN ! commpute and add the eiv velocity 81 IF( .NOT. lk_trabbl_adv ) THEN 82 zun(:,:,:) = un(:,:,:) 83 zvn(:,:,:) = vn(:,:,:) 84 zwn(:,:,:) = wn(:,:,:) 85 ENDIF 86 CALL tra_adv_eiv( kt, zun, zvn, zwn ) 87 ENDIF 65 INTEGER :: jk ! dummy loop index 66 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zun, zvn, zwn ! effective transport 67 !!---------------------------------------------------------------------- 68 69 ! ! effective transport 70 DO jk = 1, jpkm1 71 ! ! eulerian transport only 72 zun(:,:,jk) = e2u(:,:) * fse3u(:,:,jk) * un(:,:,jk) 73 zvn(:,:,jk) = e1v(:,:) * fse3v(:,:,jk) * vn(:,:,jk) 74 zwn(:,:,jk) = e1t(:,:) * e2t(:,:) * wn(:,:,jk) 75 ! 76 END DO 77 zwn(:,:,jpk) = 0.e0 ! no transport trough the bottom 78 79 ! ! add the eiv transport (if necessary) 80 IF( lk_traldf_eiv ) CALL tra_adv_eiv( kt, zun, zvn, zwn, 'TRA' ) 81 88 82 89 83 SELECT CASE ( nadv ) ! compute advection trend and add it to general trend 90 CASE ( 1 ) ; CALL tra_adv_cen2 ( kt, zun, zvn, zwn ) ! 2nd order centered scheme 91 CASE ( 2 ) ; CALL tra_adv_tvd ( kt, zun, zvn, zwn ) ! TVD scheme 92 CASE ( 3 ) ; CALL tra_adv_muscl ( kt, zun, zvn, zwn ) ! MUSCL scheme 93 CASE ( 4 ) ; CALL tra_adv_muscl2 ( kt, zun, zvn, zwn ) ! MUSCL2 scheme 94 CASE ( 5 ) ; CALL tra_adv_ubs ( kt, zun, zvn, zwn ) ! UBS scheme 95 CASE ( 6 ) ; CALL tra_adv_qck ( kt, zun, zvn, zwn ) ! QUICKEST scheme 84 CASE ( 1 ) ; CALL tra_adv_cen2 ( kt , 'TRA', zun, zvn, zwn, & 85 & tsb, tsn , tsa, jpts ) ! 2nd order centered scheme 86 CASE ( 2 ) ; CALL tra_adv_tvd ( kt , 'TRA', zun, zvn, zwn, & 87 & tsb, tsn , tsa, jpts ) ! TVD scheme 88 CASE ( 3 ) ; CALL tra_adv_muscl ( kt , 'TRA', zun, zvn, zwn, & 89 & tsb, tsa , jpts ) ! MUSCL scheme 90 CASE ( 4 ) ; CALL tra_adv_muscl2( kt , 'TRA', zun, zvn, zwn, & 91 & tsb, tsn , tsa, jpts ) ! MUSCL2 scheme 92 CASE ( 5 ) ; CALL tra_adv_ubs ( kt , 'TRA', zun, zvn, zwn, & 93 & tsb, tsn , tsa, jpts ) ! UBS scheme 94 CASE ( 6 ) ; CALL tra_adv_qck ( kt , 'TRA', zun, zvn, zwn, & 95 & tsb, tsn , tsa, jpts ) ! QUICKEST scheme 96 96 ! 97 CASE (-1 ) ! esopa: test all possibility with control print 98 CALL tra_adv_cen2 ( kt, zun, zvn, zwn ) 99 CALL prt_ctl( tab3d_1=ta, clinfo1=' adv0 - Ta: ', mask1=tmask, & 100 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 101 CALL tra_adv_tvd ( kt, zun, zvn, zwn ) 102 CALL prt_ctl( tab3d_1=ta, clinfo1=' adv2 - Ta: ', mask1=tmask, & 103 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 104 CALL tra_adv_muscl ( kt, zun, zvn, zwn ) 105 CALL prt_ctl( tab3d_1=ta, clinfo1=' adv3 - Ta: ', mask1=tmask, & 106 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 107 CALL tra_adv_muscl2 ( kt, zun, zvn, zwn ) 108 CALL prt_ctl( tab3d_1=ta, clinfo1=' adv4 - Ta: ', mask1=tmask, & 109 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 110 CALL tra_adv_ubs ( kt, zun, zvn, zwn ) 111 CALL prt_ctl( tab3d_1=ta, clinfo1=' adv5 - Ta: ', mask1=tmask, & 112 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 113 CALL tra_adv_qck ( kt, zun, zvn, zwn ) 114 CALL prt_ctl( tab3d_1=ta, clinfo1=' adv6 - Ta: ', mask1=tmask, & 115 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 97 CASE (-1 ) ! esopa: test all possibility with control pr 98 CALL tra_adv_cen2 ( kt , 'TRA', zun, zvn, zwn, & 99 & tsb, tsn , tsa, jpts ) 100 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv0 - Ta: ', mask1=tmask, & 101 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 102 CALL tra_adv_tvd ( kt , 'TRA', zun, zvn, zwn, & 103 & tsb, tsn , tsa, jpts ) 104 CALL tra_adv_tvd ( kt, 'TRA', zun, zvn, zwn, tsb, tsn, tsa, jpts ) 105 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv1 - Ta: ', mask1=tmask, & 106 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 107 CALL tra_adv_muscl ( kt , 'TRA', zun, zvn, zwn, & 108 & tsb, tsa , jpts ) 109 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv3 - Ta: ', mask1=tmask, & 110 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 111 CALL tra_adv_muscl2( kt , 'TRA', zun, zvn, zwn, & 112 & tsb, tsn , tsa, jpts ) 113 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv4 - Ta: ', mask1=tmask, & 114 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 115 CALL tra_adv_ubs ( kt , 'TRA', zun, zvn, zwn, & 116 & tsb, tsn , tsa, jpts ) 117 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv5 - Ta: ', mask1=tmask, & 118 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 119 CALL tra_adv_qck ( kt , 'TRA', zun, zvn, zwn, & 120 & tsb, tsn , tsa, jpts ) 121 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv6 - Ta: ', mask1=tmask, & 122 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 123 ! 116 124 END SELECT 117 125 … … 121 129 122 130 ! ! print mean trends (used for debugging) 123 IF(ln_ctl) CALL prt_ctl( tab3d_1=t a, clinfo1=' adv - Ta: ', mask1=tmask, &124 & tab3d_2= sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )131 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv - Ta: ', mask1=tmask, & 132 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 125 133 ! 126 134 END SUBROUTINE tra_adv 127 135 128 136 129 SUBROUTINE tra_adv_ ctl137 SUBROUTINE tra_adv_init 130 138 !!--------------------------------------------------------------------- 131 !! *** ROUTINE tra_adv_ ctl***139 !! *** ROUTINE tra_adv_init *** 132 140 !! 133 141 !! ** Purpose : Control the consistency between namelist options for … … 146 154 IF(lwp) THEN ! Namelist print 147 155 WRITE(numout,*) 148 WRITE(numout,*) 'tra_adv_ ctl: choice/control of the tracer advection scheme'156 WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme' 149 157 WRITE(numout,*) '~~~~~~~~~~~' 150 158 WRITE(numout,*) ' Namelist namtra_adv : chose a advection scheme for tracers' … … 188 196 IF( nadv == 5 ) WRITE(numout,*) ' UBS scheme is used' 189 197 IF( nadv == 6 ) WRITE(numout,*) ' QUICKEST scheme is used' 198 IF( nadv == 7 ) WRITE(numout,*) ' SMOLAR scheme is used' 190 199 IF( nadv == -1 ) WRITE(numout,*) ' esopa test: use all advection scheme' 191 200 ENDIF 192 201 ! 193 END SUBROUTINE tra_adv_ ctl202 END SUBROUTINE tra_adv_init 194 203 195 204 !!====================================================================== -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_cen2.F90
r1559 r2024 2 2 !!====================================================================== 3 3 !! *** MODULE traadv_cen2 *** 4 !! Ocean activetracers: horizontal & vertical advective trend4 !! Ocean tracers: horizontal & vertical advective trend 5 5 !!====================================================================== 6 6 !! History : 8.2 ! 2001-08 (G. Madec, E. Durand) trahad+trazad=traadv … … 11 11 !! - ! 2006-07 (G. madec) add ups_orca_set routine 12 12 !! 3.2 ! 2009-07 (G. Madec) add avmb, avtb in restart for cen2 advection 13 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport 13 14 !!---------------------------------------------------------------------- 14 15 … … 19 20 !! area (set for orca 2 and 4 only) 20 21 !!---------------------------------------------------------------------- 21 USE oce ! ocean dynamics and active tracers22 USE oce, ONLY: tsn ! now ocean temperature and salinity 22 23 USE dom_oce ! ocean space and time domain 23 USE sbc_oce ! surface boundary condition: ocean24 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient25 USE trdmod_oce ! ocean variables trends26 24 USE eosbn2 ! equation of state 27 USE trdmod ! ocean active tracers trends 25 USE trdmod_oce ! tracers trends 26 USE trdtra ! tracers trends 28 27 USE closea ! closed sea 29 USE trabbl ! advective term in the BBL30 USE sbcmod ! surface Boundary Condition31 28 USE sbcrnf ! river runoffs 32 29 USE in_out_manager ! I/O manager 33 30 USE iom ! IOM library 34 USE lib_mpp35 USE lbclnk ! ocean lateral boundary condition (or mpp link)36 31 USE diaptr ! poleward transport diagnostics 37 USE prtctl ! Print control38 32 USE zdf_oce ! ocean vertical physics 39 33 USE restart ! ocean restart … … 45 39 PUBLIC ups_orca_set ! routine used by traadv_cen2_jki.F90 46 40 47 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: upsmsk !: mixed upstream/centered scheme near some straits 41 LOGICAL :: l_trd ! flag to compute trends 42 43 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: upsmsk !: mixed upstream/centered scheme near some straits 48 44 ! ! and in closed seas (orca 2 and 4 configurations) 49 50 REAL(wp), DIMENSION(jpi,jpj) :: btr2 ! inverse of T-point surface [1/(e1t*e2t)]51 52 45 !! * Substitutions 53 46 # include "domzgr_substitute.h90" … … 61 54 CONTAINS 62 55 63 SUBROUTINE tra_adv_cen2( kt, pun, pvn, pwn ) 56 SUBROUTINE tra_adv_cen2( kt , cdtype, pun , pvn, pwn, & 57 & ptrab, ptran , ptraa, kjpt ) 64 58 !!---------------------------------------------------------------------- 65 59 !! *** ROUTINE tra_adv_cen2 *** … … 77 71 !! Part I : horizontal advection 78 72 !! * centered flux: 79 !! zcenu = e2u*e3u un mi( tn)80 !! zcenv = e1v*e3v vn mj( tn)73 !! zcenu = e2u*e3u un mi(ptran) 74 !! zcenv = e1v*e3v vn mj(ptran) 81 75 !! * upstream flux: 82 !! zupsu = e2u*e3u un ( tb(i) or tb(i-1) ) [un>0 or <0]83 !! zupsv = e1v*e3v vn ( tb(j) or tb(j-1) ) [vn>0 or <0]76 !! zupsu = e2u*e3u un (ptrab(i) or ptrab(i-1) ) [un>0 or <0] 77 !! zupsv = e1v*e3v vn (ptrab(j) or ptrab(j-1) ) [vn>0 or <0] 84 78 !! * mixed upstream / centered horizontal advection scheme 85 79 !! zcofi = max(zind(i+1), zind(i)) … … 88 82 !! zwy = zcofj * zupsv + (1-zcofj) * zcenv 89 83 !! * horizontal advective trend (divergence of the fluxes) 90 !! zt a = 1/(e1t*e2t*e3t) { di-1[zwx] + dj-1[zwy] }84 !! ztra = 1/(e1t*e2t*e3t) { di-1[zwx] + dj-1[zwy] } 91 85 !! * Add this trend now to the general trend of tracer (ta,sa): 92 !! (ta,sa) = (ta,sa) + ( zta , zsa )86 !! ptraa = ptraa + ztra 93 87 !! * trend diagnostic ('key_trdtra' defined): the trend is 94 88 !! saved for diagnostics. The trends saved is expressed as 95 89 !! Uh.gradh(T), i.e. 96 !! save trend = zta + tn divn 97 !! In addition, the advective trend in the two horizontal direc- 98 !! tion is also re-computed as Uh gradh(T). Indeed hadt+tn divn is 99 !! equal to (in s-coordinates, and similarly in z-coord.): 100 !! zta+tn*divn=1/(e1t*e2t*e3t) { mi-1( e2u*e3u un di[tn] ) 101 !! +mj-1( e1v*e3v vn mj[tn] ) } 102 !! NB:in z-coordinate - full step (ln_zco=T) e3u=e3v=e3t, so 103 !! they vanish from the expression of the flux and divergence. 90 !! save trend = ztra + ptran divn 104 91 !! 105 92 !! Part II : vertical advection 106 93 !! For temperature (idem for salinity) the advective trend is com- 107 94 !! puted as follows : 108 !! zt a = 1/e3t dk+1[ zwz ]95 !! ztra = 1/e3t dk+1[ zwz ] 109 96 !! where the vertical advective flux, zwz, is given by : 110 97 !! zwz = zcofk * zupst + (1-zcofk) * zcent 111 98 !! with 112 !! zupsv = upstream flux = wn * ( tb(k) or tb(k-1) ) [wn>0 or <0]99 !! zupsv = upstream flux = wn * (ptrab(k) or ptrab(k-1) ) [wn>0 or <0] 113 100 !! zcenu = centered flux = wn * mk(tn) 114 101 !! The surface boundary condition is : 115 102 !! variable volume (lk_vvl = T) : zero advective flux 116 !! lin. free-surf (lk_vvl = F) : wn(:,:,1) * tn(:,:,1)103 !! lin. free-surf (lk_vvl = F) : wn(:,:,1) * ptran(:,:,1) 117 104 !! Add this trend now to the general trend of tracer (ta,sa): 118 !! (ta,sa) = (ta,sa) + ( zta , zsa )105 !! ptraa = ptraa + ztra 119 106 !! Trend diagnostic ('key_trdtra' defined): the trend is 120 107 !! saved for diagnostics. The trends saved is expressed as : 121 !! save trend = w.gradz(T) = zta - tn divn. 122 !! 123 !! ** Action : - update (ta,sa) with the now advective tracer trends 124 !! - save trends in (ztrdt,ztrds) ('key_trdtra') 125 !!---------------------------------------------------------------------- 126 USE oce, ONLY : zwx => ua ! use ua as workspace 127 USE oce, ONLY : zwy => va ! use va as workspace 128 !! 129 INTEGER , INTENT(in) :: kt ! ocean time-step index 130 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pun ! ocean velocity u-component 131 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvn ! ocean velocity v-component 132 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pwn ! ocean velocity w-component 133 !! 134 INTEGER :: ji, jj, jk ! dummy loop indices 135 REAL(wp) :: zbtr, zhw, ze3tr ! temporary scalars 136 REAL(wp) :: zfp_ui, zfp_vj, zfp_w , zfui ! - - 137 REAL(wp) :: zfm_ui, zfm_vj, zfm_w , zfvj ! - - 108 !! save trend = w.gradz(T) = ztra - ptran divn. 109 !! 110 !! ** Action : - update ptraa with the now advective tracer trends 111 !! - save trends if needed 112 !!---------------------------------------------------------------------- 113 !!* Module used 114 USE oce , zwx => ua ! use ua as workspace 115 USE oce , zwy => va ! use va as workspace 116 !!* Arguments 117 INTEGER , INTENT(in ) :: kt ! ocean time-step index 118 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 119 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun, pvn, pwn ! 3 ocean velocity components 120 INTEGER , INTENT(in ) :: kjpt ! number of tracers 121 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab, ptran ! before and now tracer fields 122 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 123 !!* Local declarations 124 INTEGER :: ji, jj, jk, jn ! dummy loop indices 125 REAL(wp) :: zbtr, ztra ! temporary scalars 126 REAL(wp) :: zfp_ui, zfp_vj, zfp_w ! - - 127 REAL(wp) :: zfm_ui, zfm_vj, zfm_w ! - - 138 128 REAL(wp) :: zcofi , zcofj , zcofk ! - - 139 REAL(wp) :: zupsut, zupsus, zcenut, zcenus ! - - 140 REAL(wp) :: zupsvt, zupsvs, zcenvt, zcenvs ! - - 141 REAL(wp) :: zupst , zupss , zcent , zcens ! - - 142 REAL(wp) :: z_hdivn_x, z_hdivn_y, z_hdivn ! - - 129 REAL(wp) :: zupsut, zcenut ! - - 130 REAL(wp) :: zupsvt, zcenvt ! - - 131 REAL(wp) :: zupst , zcent ! - - 143 132 REAL(wp) :: zice ! - - 144 133 REAL(wp), DIMENSION(jpi,jpj) :: ztfreez ! 2D workspace 145 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz, ztrdt, zind ! 3D workspace 146 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zww, ztrds ! " " 134 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz, zind ! 3D workspace 147 135 !!---------------------------------------------------------------------- 148 136 … … 157 145 IF( cp_cfg == "orca" ) CALL ups_orca_set ! set mixed Upstream/centered scheme near some straits 158 146 ! ! and in closed seas (orca2 and orca4 only) 159 !160 btr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) ! inverse of T-point surface161 !162 147 IF( jp_cfg == 2 .AND. .NOT. ln_rstart ) THEN ! Increase the background in the surface layers 163 148 avmb(1) = 10. * avmb(1) ; avtb(1) = 10. * avtb(1) … … 166 151 avmb(4) = 2.5 * avmb(4) ; avtb(4) = 2.5 * avtb(4) 167 152 ENDIF 153 ! 154 l_trd = .FALSE. 155 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 168 156 ENDIF 169 157 ! 170 158 ! Upstream / centered scheme indicator 171 159 ! ------------------------------------ 172 160 !!gm not strickly exact : the freezing point should be computed at each ocean levels... 173 161 !!gm not a big deal since cen2 is no more used in global ice-ocean simulations 174 ztfreez(:,:) = tfreez( sn(:,:,1) )162 ztfreez(:,:) = tfreez( tsn(:,:,1,jp_sal) ) 175 163 DO jk = 1, jpk 176 164 DO jj = 1, jpj 177 165 DO ji = 1, jpi 178 166 ! ! below ice covered area (if tn < "freezing"+0.1 ) 179 IF( t n(ji,jj,jk) <= ztfreez(ji,jj) + 0.1 ) THEN ; zice = 1.e0167 IF( tsn(ji,jj,jk,jp_tem) <= ztfreez(ji,jj) + 0.1 ) THEN ; zice = 1.e0 180 168 ELSE ; zice = 0.e0 181 169 ENDIF … … 189 177 END DO 190 178 191 ! I. Horizontal advection 192 ! ==================== 193 ! 194 DO jk = 1, jpkm1 195 ! ! Second order centered tracer flux at u- and v-points 196 DO jj = 1, jpjm1 197 DO ji = 1, fs_jpim1 ! vector opt. 198 ! upstream indicator 199 zcofi = MAX( zind(ji+1,jj,jk), zind(ji,jj,jk) ) 200 zcofj = MAX( zind(ji,jj+1,jk), zind(ji,jj,jk) ) 201 ! volume fluxes * 1/2 202 zfui = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 203 zfvj = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 179 DO jn = 1, kjpt 180 ! 181 ! I. Horizontal advection 182 ! ==================== 183 ! 184 DO jk = 1, jpkm1 185 ! ! Second order centered tracer flux at u- and v-points 186 DO jj = 1, jpjm1 204 187 ! 205 ! upstream scheme206 zfp_ui = zfui + ABS( zfui )207 zfp_vj = zfvj + ABS( zfvj)208 zfm_ui = zfui - ABS( zfui)209 zfm_vj = zfvj - ABS( zfvj )210 zupsut = zfp_ui * tb(ji,jj,jk) + zfm_ui * tb(ji+1,jj ,jk)211 zupsvt = zfp_vj * tb(ji,jj,jk) + zfm_vj * tb(ji ,jj+1,jk)212 zupsus = zfp_ui * sb(ji,jj,jk) + zfm_ui * sb(ji+1,jj ,jk)213 zupsvs = zfp_vj * sb(ji,jj,jk) + zfm_vj * sb(ji ,jj+1,jk)214 ! centered scheme215 zcenut = zfui * ( tn(ji,jj,jk) + tn(ji+1,jj ,jk))216 zcenvt = zfvj * ( tn(ji,jj,jk) + tn(ji ,jj+1,jk))217 zcenus = zfui * ( sn(ji,jj,jk) + sn(ji+1,jj ,jk) )218 zcenvs = zfvj * ( sn(ji,jj,jk) + sn(ji ,jj+1,jk) )219 ! mixed centered / upstream scheme220 zwx(ji,jj,jk) = zcofi * zupsut + (1.-zcofi) * zcenut221 zwy(ji,jj,jk) = zcofj * zupsvt + (1.-zcofj) * zcenvt222 zww(ji,jj,jk) = zcofi * zupsus + (1.-zcofi) * zcenus223 zwz(ji,jj,jk) = zcofj * zupsvs + (1.-zcofj) * zcenvs188 DO ji = 1, fs_jpim1 ! vector opt. 189 ! upstream indicator 190 zcofi = MAX( zind(ji+1,jj,jk), zind(ji,jj,jk) ) 191 zcofj = MAX( zind(ji,jj+1,jk), zind(ji,jj,jk) ) 192 ! 193 ! upstream scheme 194 zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 195 zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 196 zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 197 zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 198 zupsut = zfp_ui * ptrab(ji,jj,jk,jn) + zfm_ui * ptrab(ji+1,jj ,jk,jn) 199 zupsvt = zfp_vj * ptrab(ji,jj,jk,jn) + zfm_vj * ptrab(ji ,jj+1,jk,jn) 200 ! centered scheme 201 zcenut = pun(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj ,jk,jn) ) 202 zcenvt = pvn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji ,jj+1,jk,jn) ) 203 ! mixed centered / upstream scheme 204 zwx(ji,jj,jk) = 0.5 * ( zcofi * zupsut + (1.-zcofi) * zcenut ) 205 zwy(ji,jj,jk) = 0.5 * ( zcofj * zupsvt + (1.-zcofj) * zcenvt ) 206 END DO 224 207 END DO 225 208 END DO 226 ! ! Tracer flux divergence at t-point added to the general trend 227 DO jj = 2, jpjm1 228 DO ji = fs_2, fs_jpim1 ! vector opt. 229 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 230 ! 231 ta(ji,jj,jk) = ta(ji,jj,jk) - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) & 232 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) ) 233 sa(ji,jj,jk) = sa(ji,jj,jk) - zbtr * ( zww(ji,jj,jk) - zww(ji-1,jj ,jk) & 234 & + zwz(ji,jj,jk) - zwz(ji ,jj-1,jk) ) 209 210 ! II. Vertical advection 211 ! ================== 212 ! 213 ! ! Vertical advective fluxes 214 zwz(:,:,jpk) = 0.e0 ! Bottom value : flux set to zero 215 ! ! Surface value : 216 IF( lk_vvl ) THEN ; zwz(:,:, 1 ) = 0.e0 ! volume variable 217 ELSE ; zwz(:,:, 1 ) = pwn(:,:,1) * ptran(:,:,1,jn) ! linear free surface 218 ENDIF 219 ! 220 DO jk = 2, jpk ! Second order centered tracer flux at w-point 221 DO jj = 2, jpjm1 222 DO ji = fs_2, fs_jpim1 ! vector opt. 223 ! upstream indicator 224 zcofk = MAX( zind(ji,jj,jk-1), zind(ji,jj,jk) ) 225 ! mixed centered / upstream scheme 226 zfp_w = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 227 zfm_w = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 228 zupst = zfp_w * ptrab(ji,jj,jk,jn) + zfm_w * ptrab(ji,jj,jk-1,jn) 229 ! centered scheme 230 zcent = pwn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj,jk-1,jn) ) 231 ! mixed centered / upstream scheme 232 zwz(ji,jj,jk) = 0.5 * ( zcofk * zupst + (1.-zcofk) * zcent ) 233 END DO 235 234 END DO 236 235 END DO 237 END DO 238 239 240 IF( l_trdtra ) THEN ! Save the i- and j-advective trends for diagnostic (U.gradz(T) trends) 241 ! 236 237 ! II. Divergence of advective fluxes 238 ! ---------------------------------- 242 239 DO jk = 1, jpkm1 243 240 DO jj = 2, jpjm1 244 241 DO ji = fs_2, fs_jpim1 ! vector opt. 245 !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 246 ! N.B. This computation is not valid with OBC, BDY, cla, eiv, advective bbl 247 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 248 z_hdivn_x = ( e2u(ji ,jj) * fse3u(ji ,jj,jk) * pun(ji ,jj,jk) & 249 & - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 250 ! 251 ztrdt(ji,jj,jk) = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) + tn(ji,jj,jk) * z_hdivn_x 252 ztrds(ji,jj,jk) = - zbtr * ( zww(ji,jj,jk) - zww(ji-1,jj,jk) ) + sn(ji,jj,jk) * z_hdivn_x 242 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 243 ! advective trends 244 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 245 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 246 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) 247 ! advective trends added to the general tracer trends 248 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 253 249 END DO 254 250 END DO 255 251 END DO 256 CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 257 ! 258 DO jk = 1, jpkm1 ! T/S MERIDIONAL advection trends 259 DO jj = 2, jpjm1 260 DO ji = fs_2, fs_jpim1 ! vector opt. 261 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 262 z_hdivn_y = ( e1v(ji, jj) * fse3v(ji,jj ,jk) * pvn(ji,jj ,jk) & 263 & - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 264 ! 265 ztrdt(ji,jj,jk) = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) + tn(ji,jj,jk) * z_hdivn_y 266 ztrds(ji,jj,jk) = - zbtr * ( zwz(ji,jj,jk) - zwz(ji,jj-1,jk) ) + sn(ji,jj,jk) * z_hdivn_y 267 END DO 268 END DO 269 END DO 270 CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 271 ! 272 ztrdt(:,:,:) = ta(:,:,:) ; ztrds(:,:,:) = sa(:,:,:) ! Save the horizontal up-to-date ta/sa trends 273 ! 274 ENDIF 275 276 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN ! "zonal" mean advective heat and salt transport 277 pht_adv(:) = ptr_vj( zwy(:,:,:) ) 278 pst_adv(:) = ptr_vj( zwz(:,:,:) ) 279 ENDIF 280 281 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' cen2 had - Ta: ', mask1=tmask, & 282 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 283 284 285 ! II. Vertical advection 286 ! ================== 287 ! 288 zwx(:,:,jpk) = 0.e0 ; zwy(:,:,jpk) = 0.e0 ! Bottom value : flux set to zero 289 ! 290 IF( lk_vvl ) THEN ! Surface value : zero in variable volume 291 zwx(:,:, 1 ) = 0.e0 ; zwy(:,:, 1 ) = 0.e0 292 ELSE ! : linear free surface case 293 zwx(:,:, 1 ) = pwn(:,:,1) * tn(:,:,1) 294 zwy(:,:, 1 ) = pwn(:,:,1) * sn(:,:,1) 295 ENDIF 296 ! 297 DO jk = 2, jpk ! Second order centered tracer flux at w-point 298 DO jj = 2, jpjm1 299 DO ji = fs_2, fs_jpim1 ! vector opt. 300 zcofk = MAX( zind(ji,jj,jk-1), zind(ji,jj,jk) ) ! upstream indicator 301 zhw = 0.5 * pwn(ji,jj,jk) ! velocity * 1/2 302 ! 303 zfp_w = zhw + ABS( zhw ) ! upstream scheme 304 zfm_w = zhw - ABS( zhw ) 305 zupst = zfp_w * tb(ji,jj,jk) + zfm_w * tb(ji,jj,jk-1) 306 zupss = zfp_w * sb(ji,jj,jk) + zfm_w * sb(ji,jj,jk-1) 307 ! 308 zcent = zhw * ( tn(ji,jj,jk) + tn(ji,jj,jk-1) ) ! centered scheme 309 zcens = zhw * ( sn(ji,jj,jk) + sn(ji,jj,jk-1) ) 310 ! 311 zwx(ji,jj,jk) = zcofk * zupst + (1.-zcofk) * zcent ! mixed centered / upstream scheme 312 zwy(ji,jj,jk) = zcofk * zupss + (1.-zcofk) * zcens 313 END DO 314 END DO 315 END DO 316 ! 317 DO jk = 1, jpkm1 ! divergence of Tracer flux added to the general trend 318 DO jj = 2, jpjm1 319 DO ji = fs_2, fs_jpim1 ! vector opt. 320 ze3tr = 1. / fse3t(ji,jj,jk) 321 ta(ji,jj,jk) = ta(ji,jj,jk) - ze3tr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) 322 sa(ji,jj,jk) = sa(ji,jj,jk) - ze3tr * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) 323 END DO 324 END DO 325 END DO 326 327 IF( l_trdtra ) THEN ! Save the vertical advective trends for diagnostic (W gradz(T) trends) 328 DO jk = 1, jpkm1 329 DO jj = 2, jpjm1 330 DO ji = fs_2, fs_jpim1 ! vector opt. 331 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 332 z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 333 z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 334 ! 335 z_hdivn = (z_hdivn_x + z_hdivn_y) * zbtr 336 ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn 337 ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 338 END DO 339 END DO 340 END DO 341 CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 342 ENDIF 343 344 ! write avmb, avtb in restart (traadv_cen2 requires a modified avmb, avtb that are 252 253 ! ! trend diagnostics (contribution of upstream fluxes) 254 IF( l_trd ) THEN 255 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptran(:,:,:,jn) ) 256 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptran(:,:,:,jn) ) 257 CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptran(:,:,:,jn) ) 258 END IF 259 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 260 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 261 IF( jn == jp_tem ) pht_adv(:) = ptr_vj( zwy(:,:,:) ) 262 IF( jn == jp_sal ) pst_adv(:) = ptr_vj( zwy(:,:,:) ) 263 ENDIF 264 ! 265 ENDDO 266 345 267 ! --------------------------- required in restart file to ensure restartability) 346 268 ! avmb, avtb will be read in zdfini in restart case as they are used in zdftke, kpp etc... 347 IF( lrst_oce ) THEN269 IF( lrst_oce .AND. cdtype == 'TRA' ) THEN 348 270 CALL iom_rstput( kt, nitrst, numrow, 'avmb', avmb ) 349 271 CALL iom_rstput( kt, nitrst, numrow, 'avtb', avtb ) 350 272 ENDIF 351 352 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' cen2 zad - Ta: ', mask1=tmask, &353 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )354 273 ! 355 274 END SUBROUTINE tra_adv_cen2 -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_eiv.F90
r1756 r2024 2 2 !!====================================================================== 3 3 !! *** MODULE traadv_eiv *** 4 !! Ocean activetracers: advection trend - eddy induced velocity4 !! Ocean tracers: advection trend - eddy induced velocity 5 5 !!====================================================================== 6 !! History : 9.0 ! 05-11 (G. Madec) Original code, from traldf and zdf _iso 6 !! History : 9.0 ! 05-11 (G. Madec) Original code, from traldf and zdf _iso 7 !! 3.3 ! 10-05 (C. Ethe, G. Madec) merge TRC-TRA 7 8 !!---------------------------------------------------------------------- 8 9 #if defined key_traldf_eiv || defined key_esopa … … 45 46 CONTAINS 46 47 47 SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn )48 SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn, cdtype ) 48 49 !!---------------------------------------------------------------------- 49 50 !! *** ROUTINE tra_adv_eiv *** … … 63 64 !! ** Action : - add to p.n the eiv component 64 65 !!---------------------------------------------------------------------- 65 INTEGER , INTENT(in ) :: kt ! ocean time-step index 66 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun ! in : 3 ocean velocity components 67 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pvn ! out: 3 ocean velocity components 68 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pwn ! increased by the eiv 66 INTEGER , INTENT(in ) :: kt ! ocean time-step index 67 CHARACTER(len=3), INTENT(in) :: cdtype ! =TRA or TRC (tracer indicator) 68 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pun ! in : 3 ocean velocity components 69 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pvn ! out: 3 ocean velocity components 70 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pwn ! increased by the eiv 69 71 !! 70 72 INTEGER :: ji, jj, jk ! dummy loop indices 71 73 REAL(wp) :: zuwk, zuwk1, zuwi, zuwi1 ! temporary scalar 72 74 REAL(wp) :: zvwk, zvwk1, zvwj, zvwj1 ! " " 73 REAL(wp) :: zu_eiv, zv_eiv, zw_eiv ! " "74 # if defined key_diaeiv 75 REAL(wp), DIMENSION(jpi,jpj) :: zu_eiv, zv_eiv, zw_eiv ! " " 76 # if defined key_diaeiv 75 77 REAL(wp) :: zztmp ! " " 76 78 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! " " … … 82 84 IF(lwp) WRITE(numout,*) 'tra_adv_eiv : eddy induced advection :' 83 85 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ add to velocity fields the eiv component' 84 # if defined key_diaeiv 85 u_eiv(:,:,:) = 0.e0 86 v_eiv(:,:,:) = 0.e0 87 w_eiv(:,:,:) = 0.e0 86 # if defined key_diaeiv 87 IF( cdtype == 'TRA') THEN 88 u_eiv(:,:,:) = 0.e0 89 v_eiv(:,:,:) = 0.e0 90 w_eiv(:,:,:) = 0.e0 91 END IF 88 92 # endif 89 93 ENDIF 90 ! ! ================= 94 95 zu_eiv(:,:) = 0.e0 ; zv_eiv(:,:) = 0.e0 ; zw_eiv(:,:) = 0.e0 96 ! ================= 91 97 DO jk = 1, jpkm1 ! Horizontal slab 92 98 ! ! ================= … … 98 104 zvwk1= ( wslpj(ji,jj,jk+1) + wslpj(ji,jj+1,jk+1) ) * fsaeiv(ji,jj,jk+1) * vmask(ji,jj,jk+1) 99 105 100 zu_eiv = 0.5 * umask(ji,jj,jk) * ( zuwk - zuwk1 ) / fse3u(ji,jj,jk)101 zv_eiv = 0.5 * vmask(ji,jj,jk) * ( zvwk - zvwk1 ) / fse3v(ji,jj,jk)106 zu_eiv(ji,jj) = 0.5 * umask(ji,jj,jk) * ( zuwk - zuwk1 ) 107 zv_eiv(ji,jj) = 0.5 * vmask(ji,jj,jk) * ( zvwk - zvwk1 ) 102 108 103 pun(ji,jj,jk) = pun(ji,jj,jk) + zu_eiv 104 pvn(ji,jj,jk) = pvn(ji,jj,jk) + zv_eiv 105 # if defined key_diaeiv 106 u_eiv(ji,jj,jk) = zu_eiv 107 v_eiv(ji,jj,jk) = zv_eiv 108 # endif 109 pun(ji,jj,jk) = pun(ji,jj,jk) + e2u(ji,jj) * zu_eiv(ji,jj) 110 pvn(ji,jj,jk) = pvn(ji,jj,jk) + e1v(ji,jj) * zv_eiv(ji,jj) 109 111 END DO 110 112 END DO 113 # if defined key_diaeiv 114 IF( cdtype == 'TRA') THEN 115 u_eiv(:,:,jk) = zu_eiv(:,:) / fse3u(:,:,jk) 116 v_eiv(:,:,jk) = zv_eiv(:,:) / fse3v(:,:,jk) 117 END IF 118 # endif 111 119 IF( jk >=2 ) THEN ! jk=1 zw_eiv=0, not computed 112 120 DO jj = 2, jpjm1 … … 118 126 zvwj1 = ( wslpj(ji,jj,jk)+wslpj(ji,jj+1,jk) ) * fsaeiv(ji,jj ,jk) * e1v(ji ,jj) * vmask(ji ,jj,jk) 119 127 120 zw_eiv = - 0.5 * tmask(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj ) / ( e1t(ji,jj)*e2t(ji,jj) )128 zw_eiv(ji,jj) = - 0.5 * tmask(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj ) 121 129 # else 122 130 zuwi = ( wslpi(ji,jj,jk) + wslpi(ji-1,jj,jk) ) * e2u(ji-1,jj) * umask(ji-1,jj,jk) … … 125 133 zvwj1 = ( wslpj(ji,jj,jk) + wslpj(ji,jj+1,jk) ) * e1v(ji ,jj) * vmask(ji ,jj,jk) 126 134 127 zw_eiv = - 0.5 * tmask(ji,jj,jk) * fsaeiw(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj ) & 128 & / ( e1t(ji,jj)*e2t(ji,jj) ) 135 zw_eiv(ji,jj) = - 0.5 * tmask(ji,jj,jk) * fsaeiw(ji,jj,jk) * ( zuwi1 - zuwi + zvwj1 - zvwj ) 129 136 # endif 130 pwn(ji,jj,jk) = pwn(ji,jj,jk) + zw_eiv 131 132 # if defined key_diaeiv 133 w_eiv(ji,jj,jk) = zw_eiv 134 # endif 137 pwn(ji,jj,jk) = pwn(ji,jj,jk) + zw_eiv(ji,jj) 135 138 END DO 136 139 END DO 140 # if defined key_diaeiv 141 IF( cdtype == 'TRA') w_eiv(:,:,jk) = zw_eiv(:,:) / ( e1t(:,:) * e2t(:,:) ) 142 # endif 137 143 ENDIF 138 144 ! ! ================= … … 140 146 ! ! ================= 141 147 142 # if defined key_diaeiv 143 CALL iom_put( "uoce_eiv", u_eiv ) ! i-eiv current 144 CALL iom_put( "voce_eiv", v_eiv ) ! j-eiv current 145 CALL iom_put( "woce_eiv", w_eiv ) ! vert. eiv current 146 IF( lk_diaar5 ) THEN 147 zztmp = 0.5 * rau0 * rcp 148 z2d(:,:) = 0.e0 149 DO jk = 1, jpkm1 150 DO jj = 2, jpjm1 151 DO ji = fs_2, fs_jpim1 ! vector opt. 152 z2d(ji,jj) = z2d(ji,jj) + zztmp * u_eiv(ji,jj,jk) * (tn(ji,jj,jk)+tn(ji+1,jj,jk)) * e1u(ji,jj) * fse3u(ji,jj,jk) 148 # if defined key_diaeiv 149 IF( cdtype == 'TRA') THEN 150 CALL iom_put( "uoce_eiv", u_eiv ) ! i-eiv current 151 CALL iom_put( "voce_eiv", v_eiv ) ! j-eiv current 152 CALL iom_put( "woce_eiv", w_eiv ) ! vert. eiv current 153 IF( lk_diaar5 ) THEN 154 zztmp = 0.5 * rau0 * rcp 155 z2d(:,:) = 0.e0 156 DO jk = 1, jpkm1 157 DO jj = 2, jpjm1 158 DO ji = fs_2, fs_jpim1 ! vector opt. 159 z2d(ji,jj) = z2d(ji,jj) + zztmp * u_eiv(ji,jj,jk) & 160 & * (tsn(ji,jj,jk,jp_tem)+tsn(ji+1,jj,jk,jp_tem)) * e1u(ji,jj) * fse3u(ji,jj,jk) 161 END DO 153 162 END DO 154 163 END DO 155 END DO 156 CALL lbc_lnk( z2d, 'U', -1. ) 157 CALL iom_put( "ueiv_heattr", z2d ) ! heat transport in i-direction 158 z2d(:,:) = 0.e0 159 DO jk = 1, jpkm1 160 DO jj = 2, jpjm1 161 DO ji = fs_2, fs_jpim1 ! vector opt. 162 z2d(ji,jj) = z2d(ji,jj) + zztmp * v_eiv(ji,jj,jk) * (tn(ji,jj,jk)+tn(ji,jj+1,jk)) * e2v(ji,jj) * fse3v(ji,jj,jk) 164 CALL lbc_lnk( z2d, 'U', -1. ) 165 CALL iom_put( "ueiv_heattr", z2d ) ! heat transport in i-direction 166 z2d(:,:) = 0.e0 167 DO jk = 1, jpkm1 168 DO jj = 2, jpjm1 169 DO ji = fs_2, fs_jpim1 ! vector opt. 170 z2d(ji,jj) = z2d(ji,jj) + zztmp * v_eiv(ji,jj,jk) & 171 & * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * e2v(ji,jj) * fse3v(ji,jj,jk) 172 END DO 163 173 END DO 164 174 END DO 165 END DO166 CALL lbc_lnk( z2d, 'V', -1. )167 CALL iom_put( "veiv_heattr", z2d ) ! heat transport in i-direction168 ENDIF175 CALL lbc_lnk( z2d, 'V', -1. ) 176 CALL iom_put( "veiv_heattr", z2d ) ! heat transport in i-direction 177 ENDIF 178 END IF 169 179 # endif 170 180 ! … … 176 186 !!---------------------------------------------------------------------- 177 187 CONTAINS 178 SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn ) ! Empty routine 188 SUBROUTINE tra_adv_eiv( kt, pun, pvn, pwn, cdtype ) ! Empty routine 189 INTEGER , INTENT(in ) :: kt ! ocean time-step index 190 CHARACTER(len=3), INTENT(in) :: cdtype ! =TRA or TRC (tracer indicator) 179 191 REAL, DIMENSION(:,:,:) :: pun, pvn, pwn 180 WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 192 WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt 193 WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', cdtype 194 WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 181 195 END SUBROUTINE tra_adv_eiv 182 196 #endif -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_muscl.F90
r1528 r2024 2 2 !!====================================================================== 3 3 !! *** MODULE traadv_muscl *** 4 !! Ocean activetracers: horizontal & vertical advective trend4 !! Ocean tracers: horizontal & vertical advective trend 5 5 !!====================================================================== 6 !! History : ! 06-00 (A.Estublier) for passive tracers 7 !! ! 01-08 (E.Durand, G.Madec) adapted for T & S 8 !! 8.5 ! 02-06 (G. Madec) F90: Free form and module 6 !! History : ! 2000-06 (A.Estublier) for passive tracers 7 !! ! 2001-08 (E.Durand, G.Madec) adapted for T & S 8 !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module 9 !! 3.2 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport 9 10 !!---------------------------------------------------------------------- 10 11 … … 15 16 USE oce ! ocean dynamics and active tracers 16 17 USE dom_oce ! ocean space and time domain 17 USE trdmod ! ocean activetracers trends18 USE trd mod_oce ! ocean variables trends18 USE trdmod_oce ! tracers trends 19 USE trdtra ! tracers trends 19 20 USE in_out_manager ! I/O manager 20 21 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient … … 23 24 USE lbclnk ! ocean lateral boundary condition (or mpp link) 24 25 USE diaptr ! poleward transport diagnostics 25 USE prtctl ! Print control 26 26 27 27 28 IMPLICIT NONE … … 29 30 30 31 PUBLIC tra_adv_muscl ! routine called by step.F90 32 33 LOGICAL :: l_trd ! flag to compute trends 31 34 32 35 !! * Substitutions … … 41 44 CONTAINS 42 45 43 SUBROUTINE tra_adv_muscl( kt, pun, pvn, pwn ) 46 SUBROUTINE tra_adv_muscl( kt , cdtype, pun, pvn, pwn, & 47 & ptrab, ptraa , kjpt ) 44 48 !!---------------------------------------------------------------------- 45 49 !! *** ROUTINE tra_adv_muscl *** … … 52 56 !! 53 57 !! ** Action : - update (ta,sa) with the now advective tracer trends 54 !! - save trends in (ztrdt,ztrds) ('key_trdtra')58 !! - save trends 55 59 !! 56 60 !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation 57 61 !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 58 62 !!---------------------------------------------------------------------- 59 USE oce, ONLY : ztrdt => ua ! use ua as workspace 60 USE oce, ONLY : ztrds => va ! use va as workspace 61 !! 62 INTEGER , INTENT(in) :: kt ! ocean time-step index 63 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pun ! ocean velocity u-component 64 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvn ! ocean velocity v-component 65 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pwn ! ocean velocity w-component 66 !! 67 INTEGER :: ji, jj, jk ! dummy loop indices 68 REAL(wp) :: & 69 zu, zv, zw, zeu, zev, & 70 zew, zbtr, zstep, & 71 z0u, z0v, z0w, & 72 zzt1, zzt2, zalpha, & 73 zzs1, zzs2, z2, & 74 zta, zsa, & 75 z_hdivn_x, z_hdivn_y, z_hdivn 76 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zt1, zt2, ztp1, ztp2 ! 3D workspace 77 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zs1, zs2, zsp1, zsp2 ! " " 63 !!* Module used 64 USE oce , zwx => ua ! use ua as workspace 65 USE oce , zwy => va ! use va as workspace 66 !!* Arguments 67 INTEGER , INTENT(in ) :: kt ! ocean time-step index 68 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 69 INTEGER , INTENT(in ) :: kjpt ! number of tracers 70 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun, pvn, pwn ! 3 ocean velocity components 71 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 72 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 73 !!* Local declarations 74 INTEGER :: ji, jj, jk, jn ! dummy loop indices 75 REAL(wp) :: zu, z0u, zzwx 76 REAL(wp) :: zv, z0v, zzwy 77 REAL(wp) :: zw, z0w 78 REAL(wp) :: ztra, zbtr, z2, zdt, zalpha 79 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zslpx, zslpy ! 3D workspace 78 80 !!---------------------------------------------------------------------- 79 81 … … 82 84 WRITE(numout,*) 'tra_adv : MUSCL advection scheme' 83 85 WRITE(numout,*) '~~~~~~~' 86 ! 87 l_trd = .FALSE. 88 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 84 89 ENDIF 85 90 … … 87 92 ELSE ; z2 = 2. 88 93 ENDIF 89 90 ! I. Horizontal advective fluxes 91 ! ------------------------------ 92 ! first guess of the slopes 93 ! interior values 94 DO jk = 1, jpkm1 95 DO jj = 1, jpjm1 96 DO ji = 1, fs_jpim1 ! vector opt. 97 zt1(ji,jj,jk) = umask(ji,jj,jk) * ( tb(ji+1,jj,jk) - tb(ji,jj,jk) ) 98 zs1(ji,jj,jk) = umask(ji,jj,jk) * ( sb(ji+1,jj,jk) - sb(ji,jj,jk) ) 99 zt2(ji,jj,jk) = vmask(ji,jj,jk) * ( tb(ji,jj+1,jk) - tb(ji,jj,jk) ) 100 zs2(ji,jj,jk) = vmask(ji,jj,jk) * ( sb(ji,jj+1,jk) - sb(ji,jj,jk) ) 101 END DO 102 END DO 103 END DO 104 ! bottom values 105 zt1(:,:,jpk) = 0.e0 ; zt2(:,:,jpk) = 0.e0 106 zs1(:,:,jpk) = 0.e0 ; zs2(:,:,jpk) = 0.e0 107 108 ! lateral boundary conditions on zt1, zt2 ; zs1, zs2 (changed sign) 109 CALL lbc_lnk( zt1, 'U', -1. ) ; CALL lbc_lnk( zs1, 'U', -1. ) 110 CALL lbc_lnk( zt2, 'V', -1. ) ; CALL lbc_lnk( zs2, 'V', -1. ) 111 112 ! Slopes 113 ! interior values 114 DO jk = 1, jpkm1 115 DO jj = 2, jpj 116 DO ji = fs_2, jpi ! vector opt. 117 ztp1(ji,jj,jk) = ( zt1(ji,jj,jk) + zt1(ji-1,jj ,jk) ) & 118 & * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji-1,jj ,jk) ) ) 119 zsp1(ji,jj,jk) = ( zs1(ji,jj,jk) + zs1(ji-1,jj ,jk) ) & 120 & * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji-1,jj ,jk) ) ) 121 ztp2(ji,jj,jk) = ( zt2(ji,jj,jk) + zt2(ji ,jj-1,jk) ) & 122 & * ( 0.25 + SIGN( 0.25, zt2(ji,jj,jk) * zt2(ji ,jj-1,jk) ) ) 123 zsp2(ji,jj,jk) = ( zs2(ji,jj,jk) + zs2(ji ,jj-1,jk) ) & 124 & * ( 0.25 + SIGN( 0.25, zs2(ji,jj,jk) * zs2(ji ,jj-1,jk) ) ) 125 END DO 126 END DO 127 END DO 128 ! bottom values 129 ztp1(:,:,jpk) = 0.e0 ; ztp2(:,:,jpk) = 0.e0 130 zsp1(:,:,jpk) = 0.e0 ; zsp2(:,:,jpk) = 0.e0 131 132 ! Slopes limitation 133 DO jk = 1, jpkm1 134 DO jj = 2, jpj 135 DO ji = fs_2, jpi ! vector opt. 136 ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) ) & 137 & * MIN( ABS( ztp1(ji ,jj,jk) ), & 138 & 2.*ABS( zt1 (ji-1,jj,jk) ), & 139 & 2.*ABS( zt1 (ji ,jj,jk) ) ) 140 zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) ) & 141 & * MIN( ABS( zsp1(ji ,jj,jk) ), & 142 & 2.*ABS( zs1 (ji-1,jj,jk) ), & 143 & 2.*ABS( zs1 (ji ,jj,jk) ) ) 144 ztp2(ji,jj,jk) = SIGN( 1., ztp2(ji,jj,jk) ) & 145 & * MIN( ABS( ztp2(ji,jj ,jk) ), & 146 & 2.*ABS( zt2 (ji,jj-1,jk) ), & 147 & 2.*ABS( zt2 (ji,jj ,jk) ) ) 148 zsp2(ji,jj,jk) = SIGN( 1., zsp2(ji,jj,jk) ) & 149 & * MIN( ABS( zsp2(ji,jj ,jk) ), & 150 & 2.*ABS( zs2 (ji,jj-1,jk) ), & 151 & 2.*ABS( zs2 (ji,jj ,jk) ) ) 152 END DO 153 END DO 154 END DO 155 156 ! Advection terms 157 ! interior values 158 DO jk = 1, jpkm1 159 zstep = z2 * rdttra(jk) 160 DO jj = 2, jpjm1 161 DO ji = fs_2, fs_jpim1 ! vector opt. 162 ! volume fluxes 163 #if defined key_zco 164 zeu = e2u(ji,jj) * pun(ji,jj,jk) 165 zev = e1v(ji,jj) * pvn(ji,jj,jk) 166 #else 167 zeu = e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 168 zev = e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 169 #endif 170 ! MUSCL fluxes 171 z0u = SIGN( 0.5, pun(ji,jj,jk) ) 172 zalpha = 0.5 - z0u 173 zu = z0u - 0.5 * pun(ji,jj,jk) * zstep / e1u(ji,jj) 174 zzt1 = tb(ji+1,jj,jk) + zu*ztp1(ji+1,jj,jk) 175 zzt2 = tb(ji ,jj,jk) + zu*ztp1(ji ,jj,jk) 176 zzs1 = sb(ji+1,jj,jk) + zu*zsp1(ji+1,jj,jk) 177 zzs2 = sb(ji ,jj,jk) + zu*zsp1(ji ,jj,jk) 178 zt1(ji,jj,jk) = zeu * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 179 zs1(ji,jj,jk) = zeu * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 180 ! 181 z0v = SIGN( 0.5, pvn(ji,jj,jk) ) 182 zalpha = 0.5 - z0v 183 zv = z0v - 0.5 * pvn(ji,jj,jk) * zstep / e2v(ji,jj) 184 zzt1 = tb(ji,jj+1,jk) + zv*ztp2(ji,jj+1,jk) 185 zzt2 = tb(ji,jj ,jk) + zv*ztp2(ji,jj ,jk) 186 zzs1 = sb(ji,jj+1,jk) + zv*zsp2(ji,jj+1,jk) 187 zzs2 = sb(ji,jj ,jk) + zv*zsp2(ji,jj ,jk) 188 zt2(ji,jj,jk) = zev * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 189 zs2(ji,jj,jk) = zev * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 190 END DO 191 END DO 192 END DO 193 194 ! lateral boundary conditions on zt1, zt2 ; zs1, zs2 (changed sign) 195 CALL lbc_lnk( zt1, 'U', -1. ) ; CALL lbc_lnk( zs1, 'U', -1. ) 196 CALL lbc_lnk( zt2, 'V', -1. ) ; CALL lbc_lnk( zs2, 'V', -1. ) 197 198 ! Tracer flux divergence at t-point added to the general trend 199 DO jk = 1, jpkm1 200 DO jj = 2, jpjm1 201 DO ji = fs_2, fs_jpim1 ! vector opt. 202 #if defined key_zco 203 zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj) ) 204 #else 205 zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 206 #endif 207 ! horizontal advective trends 208 zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj ,jk ) & 209 & + zt2(ji,jj,jk) - zt2(ji ,jj-1,jk ) ) 210 zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj ,jk ) & 211 & + zs2(ji,jj,jk) - zs2(ji ,jj-1,jk ) ) 212 ! add it to the general tracer trends 213 ta(ji,jj,jk) = ta(ji,jj,jk) + zta 214 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 215 END DO 216 END DO 217 END DO 218 219 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl had - Ta: ', mask1=tmask , & 220 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 221 222 ! Save the horizontal advective trends for diagnostics 223 IF( l_trdtra ) THEN 224 ztrdt(:,:,:) = 0.e0 ; ztrds(:,:,:) = 0.e0 225 ! 226 ! T/S ZONAL advection trends 94 ! 95 ! ! =========== 96 DO jn = 1, kjpt ! tracer loop 97 ! ! =========== 98 ! I. Horizontal advective fluxes 99 ! ------------------------------ 100 ! first guess of the slopes 101 zwx(:,:,jpk) = 0.e0 ; zwy(:,:,jpk) = 0.e0 ! bottom values 102 ! interior values 227 103 DO jk = 1, jpkm1 104 DO jj = 1, jpjm1 105 DO ji = 1, fs_jpim1 ! vector opt. 106 zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptrab(ji+1,jj,jk,jn) - ptrab(ji,jj,jk,jn) ) 107 zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptrab(ji,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 108 END DO 109 END DO 110 END DO 111 ! 112 CALL lbc_lnk( zwx, 'U', -1. ) ! lateral boundary conditions on zwx, zwy (changed sign) 113 CALL lbc_lnk( zwy, 'V', -1. ) 114 ! !-- Slopes of tracer 115 zslpx(:,:,jpk) = 0.e0 ; zslpy(:,:,jpk) = 0.e0 ! bottom values 116 DO jk = 1, jpkm1 ! interior values 117 DO jj = 2, jpj 118 DO ji = fs_2, jpi ! vector opt. 119 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & 120 & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) 121 zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & 122 & * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) 123 END DO 124 END DO 125 END DO 126 ! 127 DO jk = 1, jpkm1 ! Slopes limitation 128 DO jj = 2, jpj 129 DO ji = fs_2, jpi ! vector opt. 130 zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & 131 & 2.*ABS( zwx (ji-1,jj,jk) ), & 132 & 2.*ABS( zwx (ji ,jj,jk) ) ) 133 zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & 134 & 2.*ABS( zwy (ji,jj-1,jk) ), & 135 & 2.*ABS( zwy (ji,jj ,jk) ) ) 136 END DO 137 END DO 138 END DO ! interior values 139 140 ! !-- MUSCL horizontal advective fluxes 141 DO jk = 1, jpkm1 ! interior values 142 zdt = z2 * rdttra(jk) 228 143 DO jj = 2, jpjm1 229 144 DO ji = fs_2, fs_jpim1 ! vector opt. 230 !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 231 ! N.B. This computation is not valid along OBCs (if any) 232 #if defined key_zco 233 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 234 z_hdivn_x = ( e2u(ji ,jj) * pun(ji ,jj,jk) & 235 & - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr 236 #else 237 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 238 z_hdivn_x = ( e2u(ji ,jj) * fse3u(ji ,jj,jk) * pun(ji ,jj,jk) & 239 & - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 240 #endif 241 ztrdt(ji,jj,jk) = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj,jk) ) + tn(ji,jj,jk) * z_hdivn_x 242 ztrds(ji,jj,jk) = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj,jk) ) + sn(ji,jj,jk) * z_hdivn_x 243 END DO 244 END DO 245 END DO 246 CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 247 248 ! T/S MERIDIONAL advection trends 145 ! MUSCL fluxes 146 z0u = SIGN( 0.5, pun(ji,jj,jk) ) 147 zalpha = 0.5 - z0u 148 zu = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 149 zzwx = ptrab(ji+1,jj,jk,jn) + zu * zslpx(ji+1,jj,jk) 150 zzwy = ptrab(ji ,jj,jk,jn) + zu * zslpx(ji ,jj,jk) 151 zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 152 ! 153 z0v = SIGN( 0.5, pvn(ji,jj,jk) ) 154 zalpha = 0.5 - z0v 155 zv = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 156 zzwx = ptrab(ji,jj+1,jk,jn) + zv * zslpy(ji,jj+1,jk) 157 zzwy = ptrab(ji,jj ,jk,jn) + zv * zslpy(ji,jj ,jk) 158 zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 159 END DO 160 END DO 161 END DO 162 ! ! lateral boundary conditions on zwx, zwy (changed sign) 163 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) 164 ! 165 ! Tracer flux divergence at t-point added to the general trend 249 166 DO jk = 1, jpkm1 250 DO jj = 2, jpjm1 251 DO ji = fs_2, fs_jpim1 ! vector opt. 252 !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 253 ! N.B. This computation is not valid along OBCs (if any) 254 #if defined key_zco 255 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 256 z_hdivn_y = ( e1v(ji,jj ) * pvn(ji,jj ,jk) & 257 & - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr 258 #else 259 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 260 z_hdivn_y = ( e1v(ji, jj) * fse3v(ji,jj ,jk) * pvn(ji,jj ,jk) & 261 & - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 262 #endif 263 ztrdt(ji,jj,jk) = - zbtr * ( zt2(ji,jj,jk) - zt2(ji,jj-1,jk) ) + tn(ji,jj,jk) * z_hdivn_y 264 ztrds(ji,jj,jk) = - zbtr * ( zs2(ji,jj,jk) - zs2(ji,jj-1,jk) ) + sn(ji,jj,jk) * z_hdivn_y 265 END DO 266 END DO 267 END DO 268 CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 269 270 ! Save the up-to-date ta and sa trends 271 ztrdt(:,:,:) = ta(:,:,:) 272 ztrds(:,:,:) = sa(:,:,:) 273 ! 274 ENDIF 275 276 ! "zonal" mean advective heat and salt transport 277 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 278 IF( lk_zco ) THEN 279 DO jk = 1, jpkm1 280 DO jj = 2, jpjm1 281 DO ji = fs_2, fs_jpim1 ! vector opt. 282 zt2(ji,jj,jk) = zt2(ji,jj,jk) * fse3v(ji,jj,jk) 283 zs2(ji,jj,jk) = zs2(ji,jj,jk) * fse3v(ji,jj,jk) 167 DO jj = 2, jpjm1 168 DO ji = fs_2, fs_jpim1 ! vector opt. 169 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 170 ! horizontal advective trends 171 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 172 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) 173 ! add it to the general tracer trends 174 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 175 END DO 176 END DO 177 END DO 178 ! ! trend diagnostics (contribution of upstream fluxes) 179 IF( l_trd ) THEN 180 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptrab(:,:,:,jn) ) 181 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptrab(:,:,:,jn) ) 182 END IF 183 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 184 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 185 IF( lk_zco ) THEN 186 DO jk = 1, jpkm1 187 DO jj = 2, jpjm1 188 DO ji = fs_2, fs_jpim1 ! vector opt. 189 zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk) 190 END DO 284 191 END DO 285 192 END DO 286 END DO 193 ENDIF 194 IF( jn == jp_tem ) pht_adv(:) = ptr_vj( zwy(:,:,:) ) 195 IF( jn == jp_sal ) pst_adv(:) = ptr_vj( zwy(:,:,:) ) 287 196 ENDIF 288 pht_adv(:) = ptr_vj( zt2(:,:,:) ) 289 pst_adv(:) = ptr_vj( zs2(:,:,:) ) 290 ENDIF 291 292 ! II. Vertical advective fluxes 293 ! ----------------------------- 294 295 ! First guess of the slope 296 ! interior values 297 DO jk = 2, jpkm1 298 zt1(:,:,jk) = tmask(:,:,jk) * ( tb(:,:,jk-1) - tb(:,:,jk) ) 299 zs1(:,:,jk) = tmask(:,:,jk) * ( sb(:,:,jk-1) - sb(:,:,jk) ) 300 END DO 301 ! surface & bottom boundary conditions 302 zt1 (:,:, 1 ) = 0.e0 ; zt1 (:,:,jpk) = 0.e0 303 zs1 (:,:, 1 ) = 0.e0 ; zs1 (:,:,jpk) = 0.e0 304 305 ! Slopes 306 DO jk = 2, jpkm1 307 DO jj = 1, jpj 308 DO ji = 1, jpi 309 ztp1(ji,jj,jk) = ( zt1(ji,jj,jk) + zt1(ji,jj,jk+1) ) & 310 & * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji,jj,jk+1) ) ) 311 zsp1(ji,jj,jk) = ( zs1(ji,jj,jk) + zs1(ji,jj,jk+1) ) & 312 & * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji,jj,jk+1) ) ) 313 END DO 314 END DO 315 END DO 316 317 ! Slopes limitation 318 ! interior values 319 DO jk = 2, jpkm1 320 DO jj = 1, jpj 321 DO ji = 1, jpi 322 ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) ) & 323 & * MIN( ABS( ztp1(ji,jj,jk ) ), & 324 & 2.*ABS( zt1 (ji,jj,jk+1) ), & 325 & 2.*ABS( zt1 (ji,jj,jk ) ) ) 326 zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) ) & 327 & * MIN( ABS( zsp1(ji,jj,jk ) ), & 328 & 2.*ABS( zs1 (ji,jj,jk+1) ), & 329 & 2.*ABS( zs1 (ji,jj,jk ) ) ) 330 END DO 331 END DO 332 END DO 333 ! surface values 334 ztp1(:,:,1) = 0.e0 335 zsp1(:,:,1) = 0.e0 336 337 ! vertical advective flux 338 ! interior values 339 DO jk = 1, jpkm1 340 zstep = z2 * rdttra(jk) 341 DO jj = 2, jpjm1 342 DO ji = fs_2, fs_jpim1 ! vector opt. 343 zew = pwn(ji,jj,jk+1) 344 z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 345 zalpha = 0.5 + z0w 346 zw = z0w - 0.5 * pwn(ji,jj,jk+1)*zstep / fse3w(ji,jj,jk+1) 347 zzt1 = tb(ji,jj,jk+1) + zw*ztp1(ji,jj,jk+1) 348 zzt2 = tb(ji,jj,jk ) + zw*ztp1(ji,jj,jk ) 349 zzs1 = sb(ji,jj,jk+1) + zw*zsp1(ji,jj,jk+1) 350 zzs2 = sb(ji,jj,jk ) + zw*zsp1(ji,jj,jk ) 351 zt1(ji,jj,jk+1) = zew * ( zalpha * zzt1 + (1.-zalpha)*zzt2 ) 352 zs1(ji,jj,jk+1) = zew * ( zalpha * zzs1 + (1.-zalpha)*zzs2 ) 353 END DO 354 END DO 355 END DO 356 ! surface values 357 IF( lk_vvl ) THEN 358 ! variable volume : flux set to zero 359 zt1(:,:, 1 ) = 0.e0 360 zs1(:,:, 1 ) = 0.e0 361 ELSE 362 ! free surface-constant volume 363 zt1(:,:, 1 ) = pwn(:,:,1) * tb(:,:,1) 364 zs1(:,:, 1 ) = pwn(:,:,1) * sb(:,:,1) 365 ENDIF 366 367 ! bottom values 368 zt1(:,:,jpk) = 0.e0 369 zs1(:,:,jpk) = 0.e0 370 371 372 ! Compute & add the vertical advective trend 373 374 DO jk = 1, jpkm1 375 DO jj = 2, jpjm1 376 DO ji = fs_2, fs_jpim1 ! vector opt. 377 zbtr = 1. / fse3t(ji,jj,jk) 378 ! horizontal advective trends 379 zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji,jj,jk+1) ) 380 zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji,jj,jk+1) ) 381 ! add it to the general tracer trends 382 ta(ji,jj,jk) = ta(ji,jj,jk) + zta 383 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 384 END DO 385 END DO 386 END DO 387 388 ! Save the vertical advective trends for diagnostic 389 ! ------------------------------------------------- 390 IF( l_trdtra ) THEN 391 ! Recompute the vertical advection zta & zsa trends computed 392 ! at the step 2. above in making the difference between the new 393 ! trends and the previous one: ta()/sa - ztrdt()/ztrds() and substract 394 ! the term tn()/sn()*hdivn() to recover the W gradz(T/S) trends 395 197 198 ! II. Vertical advective fluxes 199 ! ----------------------------- 200 ! !-- first guess of the slopes 201 zwx (:,:, 1 ) = 0.e0 ; zwx (:,:,jpk) = 0.e0 ! surface & bottom boundary conditions 202 DO jk = 2, jpkm1 ! interior values 203 zwx(:,:,jk) = tmask(:,:,jk) * ( ptrab(:,:,jk-1,jn) - ptrab(:,:,jk,jn) ) 204 END DO 205 206 ! !-- Slopes of tracer 207 zslpx(:,:,1) = 0.e0 ! surface values 208 DO jk = 2, jpkm1 ! interior value 209 DO jj = 1, jpj 210 DO ji = 1, jpi 211 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & 212 & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 213 END DO 214 END DO 215 END DO 216 ! !-- Slopes limitation 217 DO jk = 2, jpkm1 ! interior values 218 DO jj = 1, jpj 219 DO ji = 1, jpi 220 zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & 221 & 2.*ABS( zwx (ji,jj,jk+1) ), & 222 & 2.*ABS( zwx (ji,jj,jk ) ) ) 223 END DO 224 END DO 225 END DO 226 ! !-- vertical advective flux 227 ! ! surface values (bottom already set to zero) 228 IF( lk_vvl ) THEN ; zwx(:,:, 1 ) = 0.e0 ! variable volume 229 ELSE ; zwx(:,:, 1 ) = pwn(:,:,1) * ptrab(:,:,1,jn) ! linear free surface 230 ENDIF 231 ! 232 DO jk = 1, jpkm1 ! interior values 233 zdt = z2 * rdttra(jk) 234 DO jj = 2, jpjm1 235 DO ji = fs_2, fs_jpim1 ! vector opt. 236 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3w(ji,jj,jk+1) ) 237 z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 238 zalpha = 0.5 + z0w 239 zw = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr 240 zzwx = ptrab(ji,jj,jk+1,jn) + zw * zslpx(ji,jj,jk+1) 241 zzwy = ptrab(ji,jj,jk ,jn) + zw * zslpx(ji,jj,jk ) 242 zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 243 END DO 244 END DO 245 END DO 246 247 ! Compute & add the vertical advective trend 396 248 DO jk = 1, jpkm1 397 DO jj = 2, jpjm1 398 DO ji = fs_2, fs_jpim1 ! vector opt. 399 #if defined key_zco 400 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 401 z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 402 z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 403 #else 404 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 405 z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 406 z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 407 #endif 408 z_hdivn = (z_hdivn_x + z_hdivn_y) * zbtr 409 ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn 410 ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 411 END DO 412 END DO 413 END DO 414 CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 415 ! 416 ENDIF 417 418 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl zad - Ta: ', mask1=tmask , & 419 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 249 DO jj = 2, jpjm1 250 DO ji = fs_2, fs_jpim1 ! vector opt. 251 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 252 ! vertical advective trends 253 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) 254 ! add it to the general tracer trends 255 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 256 END DO 257 END DO 258 END DO 259 ! ! Save the vertical advective trends for diagnostic 260 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptrab(:,:,:,jn) ) 261 ! 262 ENDDO 420 263 ! 421 264 END SUBROUTINE tra_adv_muscl -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_muscl2.F90
r1528 r2024 2 2 !!============================================================================== 3 3 !! *** MODULE traadv_muscl2 *** 4 !! Ocean activetracers: horizontal & vertical advective trend4 !! Ocean tracers: horizontal & vertical advective trend 5 5 !!============================================================================== 6 !! History : 9.0 ! 02-06 (G. Madec) from traadv_muscl 6 !! History : 1.0 ! 2002-06 (G. Madec) from traadv_muscl 7 !! 3.2 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport 7 8 !!---------------------------------------------------------------------- 8 9 … … 13 14 USE oce ! ocean dynamics and active tracers 14 15 USE dom_oce ! ocean space and time domain 15 USE trdmod ! ocean activetracers trends16 USE trd mod_oce ! ocean variables trends16 USE trdmod_oce ! tracers trends 17 USE trdtra ! tracers trends 17 18 USE in_out_manager ! I/O manager 18 19 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 19 20 USE trabbl ! tracers: bottom boundary layer 20 USE lib_mpp 21 USE lib_mpp ! distribued memory computing 21 22 USE lbclnk ! ocean lateral boundary condition (or mpp link) 22 23 USE diaptr ! poleward transport diagnostics 23 USE prtctl ! Print control 24 24 25 25 26 IMPLICIT NONE … … 28 29 !! * Accessibility 29 30 PUBLIC tra_adv_muscl2 ! routine called by step.F90 31 32 LOGICAL :: l_trd ! flag to compute trends 30 33 31 34 !! * Substitutions … … 40 43 CONTAINS 41 44 42 SUBROUTINE tra_adv_muscl2( kt, pun, pvn, pwn ) 45 SUBROUTINE tra_adv_muscl2( kt , cdtype, pun , pvn, pwn, & 46 & ptrab, ptran , ptraa, kjpt ) 43 47 !!---------------------------------------------------------------------- 44 48 !! *** ROUTINE tra_adv_muscl2 *** … … 50 54 !! ** Method : MUSCL scheme plus centered scheme at ocean boundaries 51 55 !! 52 !! ** Action : - update ( ta,sa) with the now advective tracer trends53 !! - save trends in (ztrdt,ztrds) ('key_trdtra')56 !! ** Action : - update (ptraa) with the now advective tracer trends 57 !! - save trends 54 58 !! 55 59 !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation 56 60 !! IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 57 61 !!---------------------------------------------------------------------- 58 USE oce , ztrdt => ua ! use ua as workspace 59 USE oce , ztrds => va ! use va as workspace 60 !! 61 INTEGER , INTENT(in) :: kt ! ocean time-step index 62 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pun ! ocean velocity u-component 63 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvn ! ocean velocity v-component 64 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pwn ! ocean velocity w-component 65 !! 66 INTEGER :: ji, jj, jk ! dummy loop indices 67 REAL(wp) :: & 68 zu, zv, zw, zeu, zev, & 69 zew, zbtr, zstep, & 70 z0u, z0v, z0w, & 71 zzt1, zzt2, zalpha, & 72 zzs1, zzs2, z2, & 73 zta, zsa, & 74 z_hdivn_x, z_hdivn_y, z_hdivn 75 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zt1, zt2, ztp1, ztp2 ! 3D workspace 76 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zs1, zs2, zsp1, zsp2 ! " " 62 !!* Module used 63 USE oce , zwx => ua ! use ua as workspace 64 USE oce , zwy => va ! use va as workspace 65 !!* Arguments 66 INTEGER , INTENT(in ) :: kt ! ocean time-step index 67 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 68 INTEGER , INTENT(in ) :: kjpt ! number of tracers 69 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun, pvn, pwn ! 3 ocean velocity components 70 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab, ptran ! before and now tracer fields 71 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 72 !!* Local declarations 73 INTEGER :: ji, jj, jk, jn ! dummy loop indices 74 REAL(wp) :: zu, z0u, zzwx 75 REAL(wp) :: zv, z0v, zzwy 76 REAL(wp) :: zw, z0w 77 REAL(wp) :: ztra, zbtr, z2, zdt, zalpha 78 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zslpx, zslpy ! 3D workspace 77 79 !!---------------------------------------------------------------------- 78 80 … … 81 83 WRITE(numout,*) 'tra_adv_muscl2 : MUSCL2 advection scheme' 82 84 WRITE(numout,*) '~~~~~~~~~~~~~~~' 85 ! 86 l_trd = .FALSE. 87 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 83 88 ENDIF 84 89 … … 86 91 ELSE ; z2 = 2. 87 92 ENDIF 88 89 ! I. Horizontal advective fluxes 90 ! ------------------------------ 91 92 ! first guess of the slopes 93 ! interior values 94 DO jk = 1, jpkm1 95 DO jj = 1, jpjm1 96 DO ji = 1, fs_jpim1 ! vector opt. 97 zt1(ji,jj,jk) = umask(ji,jj,jk) * ( tb(ji+1,jj,jk) - tb(ji,jj,jk) ) 98 zs1(ji,jj,jk) = umask(ji,jj,jk) * ( sb(ji+1,jj,jk) - sb(ji,jj,jk) ) 99 zt2(ji,jj,jk) = vmask(ji,jj,jk) * ( tb(ji,jj+1,jk) - tb(ji,jj,jk) ) 100 zs2(ji,jj,jk) = vmask(ji,jj,jk) * ( sb(ji,jj+1,jk) - sb(ji,jj,jk) ) 101 END DO 102 END DO 103 END DO 104 ! bottom values 105 zt1(:,:,jpk) = 0.e0 ; zt2(:,:,jpk) = 0.e0 106 zs1(:,:,jpk) = 0.e0 ; zs2(:,:,jpk) = 0.e0 107 108 ! lateral boundary conditions on zt1, zt2 ; zs1, zs2 (changed sign) 109 CALL lbc_lnk( zt1, 'U', -1. ) ; CALL lbc_lnk( zs1, 'U', -1. ) 110 CALL lbc_lnk( zt2, 'V', -1. ) ; CALL lbc_lnk( zs2, 'V', -1. ) 111 112 ! Slopes 113 ! interior values 114 DO jk = 1, jpkm1 115 DO jj = 2, jpj 116 DO ji = fs_2, jpi ! vector opt. 117 ztp1(ji,jj,jk) = ( zt1(ji,jj,jk) + zt1(ji-1,jj ,jk) ) & 118 & * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji-1,jj ,jk) ) ) 119 zsp1(ji,jj,jk) = ( zs1(ji,jj,jk) + zs1(ji-1,jj ,jk) ) & 120 & * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji-1,jj ,jk) ) ) 121 ztp2(ji,jj,jk) = ( zt2(ji,jj,jk) + zt2(ji ,jj-1,jk) ) & 122 & * ( 0.25 + SIGN( 0.25, zt2(ji,jj,jk) * zt2(ji ,jj-1,jk) ) ) 123 zsp2(ji,jj,jk) = ( zs2(ji,jj,jk) + zs2(ji ,jj-1,jk) ) & 124 & * ( 0.25 + SIGN( 0.25, zs2(ji,jj,jk) * zs2(ji ,jj-1,jk) ) ) 125 END DO 126 END DO 127 END DO 128 ! bottom values 129 ztp1(:,:,jpk) = 0.e0 ; ztp2(:,:,jpk) = 0.e0 130 zsp1(:,:,jpk) = 0.e0 ; zsp2(:,:,jpk) = 0.e0 131 132 ! Slopes limitation 133 DO jk = 1, jpkm1 134 DO jj = 2, jpj 135 DO ji = fs_2, jpi ! vector opt. 136 ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) ) & 137 & * MIN( ABS( ztp1(ji ,jj,jk) ), & 138 & 2.*ABS( zt1 (ji-1,jj,jk) ), & 139 & 2.*ABS( zt1 (ji ,jj,jk) ) ) 140 zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) ) & 141 & * MIN( ABS( zsp1(ji ,jj,jk) ), & 142 & 2.*ABS( zs1 (ji-1,jj,jk) ), & 143 & 2.*ABS( zs1 (ji ,jj,jk) ) ) 144 ztp2(ji,jj,jk) = SIGN( 1., ztp2(ji,jj,jk) ) & 145 & * MIN( ABS( ztp2(ji,jj ,jk) ), & 146 & 2.*ABS( zt2 (ji,jj-1,jk) ), & 147 & 2.*ABS( zt2 (ji,jj ,jk) ) ) 148 zsp2(ji,jj,jk) = SIGN( 1., zsp2(ji,jj,jk) ) & 149 & * MIN( ABS( zsp2(ji,jj ,jk) ), & 150 & 2.*ABS( zs2 (ji,jj-1,jk) ), & 151 & 2.*ABS( zs2 (ji,jj ,jk) ) ) 152 END DO 153 END DO 154 END DO 155 156 ! Advection terms 157 ! interior values 158 DO jk = 1, jpkm1 159 zstep = z2 * rdttra(jk) 160 DO jj = 2, jpjm1 161 DO ji = fs_2, fs_jpim1 ! vector opt. 162 ! volume fluxes 163 #if defined key_zco 164 zeu = e2u(ji,jj) * pun(ji,jj,jk) 165 zev = e1v(ji,jj) * pvn(ji,jj,jk) 166 #else 167 zeu = e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 168 zev = e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 169 #endif 170 ! MUSCL fluxes 171 z0u = SIGN( 0.5, pun(ji,jj,jk) ) 172 zalpha = 0.5 - z0u 173 zu = z0u - 0.5 * pun(ji,jj,jk) * zstep / e1u(ji,jj) 174 zzt1 = tb(ji+1,jj,jk) + zu*ztp1(ji+1,jj,jk) 175 zzt2 = tb(ji ,jj,jk) + zu*ztp1(ji ,jj,jk) 176 zzs1 = sb(ji+1,jj,jk) + zu*zsp1(ji+1,jj,jk) 177 zzs2 = sb(ji ,jj,jk) + zu*zsp1(ji ,jj,jk) 178 zt1(ji,jj,jk) = zeu * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 179 zs1(ji,jj,jk) = zeu * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 180 ! 181 z0v = SIGN( 0.5, pvn(ji,jj,jk) ) 182 zalpha = 0.5 - z0v 183 zv = z0v - 0.5 * pvn(ji,jj,jk) * zstep / e2v(ji,jj) 184 zzt1 = tb(ji,jj+1,jk) + zv*ztp2(ji,jj+1,jk) 185 zzt2 = tb(ji,jj ,jk) + zv*ztp2(ji,jj ,jk) 186 zzs1 = sb(ji,jj+1,jk) + zv*zsp2(ji,jj+1,jk) 187 zzs2 = sb(ji,jj ,jk) + zv*zsp2(ji,jj ,jk) 188 zt2(ji,jj,jk) = zev * ( zalpha * zzt1 + (1.-zalpha) * zzt2 ) 189 zs2(ji,jj,jk) = zev * ( zalpha * zzs1 + (1.-zalpha) * zzs2 ) 190 END DO 191 END DO 192 END DO 193 194 !!!! centered scheme at lateral b.C. if off-shore velocity 195 DO jk = 1, jpkm1 196 DO jj = 2, jpjm1 197 DO ji = fs_2, fs_jpim1 ! vector opt. 198 #if defined key_zco 199 IF( umask(ji,jj,jk) == 0. ) THEN 200 IF( pun(ji+1,jj,jk) > 0. .AND. ji /= jpi ) THEN 201 zt1(ji+1,jj,jk) = e2u(ji+1,jj) * pun(ji+1,jj,jk) * ( tb(ji+1,jj,jk) + tb(ji+2,jj,jk) ) * 0.5 202 zs1(ji+1,jj,jk) = e2u(ji+1,jj) * pun(ji+1,jj,jk) * ( sb(ji+1,jj,jk) + sb(ji+2,jj,jk) ) * 0.5 93 ! 94 ! 95 DO jn = 1, kjpt ! tracer loop 96 ! ! =========== 97 ! I. Horizontal advective fluxes 98 ! ------------------------------ 99 ! first guess of the slopes 100 zwx(:,:,jpk) = 0.e0 ; zwy(:,:,jpk) = 0.e0 ! bottom values 101 ! interior values 102 DO jk = 1, jpkm1 103 DO jj = 1, jpjm1 104 DO ji = 1, fs_jpim1 ! vector opt. 105 zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptrab(ji+1,jj,jk,jn) - ptrab(ji,jj,jk,jn) ) 106 zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptrab(ji,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 107 END DO 108 END DO 109 END DO 110 ! 111 CALL lbc_lnk( zwx, 'U', -1. ) ! lateral boundary conditions on zwx, zwy (changed sign) 112 CALL lbc_lnk( zwy, 'V', -1. ) 113 ! !-- Slopes of tracer 114 zslpx(:,:,jpk) = 0.e0 ; zslpy(:,:,jpk) = 0.e0 ! bottom values 115 DO jk = 1, jpkm1 ! interior values 116 DO jj = 2, jpj 117 DO ji = fs_2, jpi ! vector opt. 118 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & 119 & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj ,jk) ) ) 120 zslpy(ji,jj,jk) = ( zwy(ji,jj,jk) + zwy(ji ,jj-1,jk) ) & 121 & * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) 122 END DO 123 END DO 124 END DO 125 ! 126 DO jk = 1, jpkm1 ! Slopes limitation 127 DO jj = 2, jpj 128 DO ji = fs_2, jpi ! vector opt. 129 zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji ,jj,jk) ), & 130 & 2.*ABS( zwx (ji-1,jj,jk) ), & 131 & 2.*ABS( zwx (ji ,jj,jk) ) ) 132 zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN( ABS( zslpy(ji,jj ,jk) ), & 133 & 2.*ABS( zwy (ji,jj-1,jk) ), & 134 & 2.*ABS( zwy (ji,jj ,jk) ) ) 135 END DO 136 END DO 137 END DO ! interior values 138 139 ! !-- MUSCL horizontal advective fluxes 140 DO jk = 1, jpkm1 ! interior values 141 zdt = z2 * rdttra(jk) 142 DO jj = 2, jpjm1 143 DO ji = fs_2, fs_jpim1 ! vector opt. 144 ! MUSCL fluxes 145 z0u = SIGN( 0.5, pun(ji,jj,jk) ) 146 zalpha = 0.5 - z0u 147 zu = z0u - 0.5 * pun(ji,jj,jk) * zdt / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 148 zzwx = ptrab(ji+1,jj,jk,jn) + zu * zslpx(ji+1,jj,jk) 149 zzwy = ptrab(ji ,jj,jk,jn) + zu * zslpx(ji ,jj,jk) 150 zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 151 ! 152 z0v = SIGN( 0.5, pvn(ji,jj,jk) ) 153 zalpha = 0.5 - z0v 154 zv = z0v - 0.5 * pvn(ji,jj,jk) * zdt / ( e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) ) 155 zzwx = ptrab(ji,jj+1,jk,jn) + zv * zslpy(ji,jj+1,jk) 156 zzwy = ptrab(ji,jj ,jk,jn) + zv * zslpy(ji,jj ,jk) 157 zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 158 END DO 159 END DO 160 END DO 161 162 !! centered scheme at lateral b.C. if off-shore velocity 163 DO jk = 1, jpkm1 164 DO jj = 2, jpjm1 165 DO ji = fs_2, fs_jpim1 ! vector opt. 166 IF( umask(ji,jj,jk) == 0. ) THEN 167 IF( pun(ji+1,jj,jk) > 0. .AND. ji /= jpi ) THEN 168 zwx(ji+1,jj,jk) = 0.5 * pun(ji+1,jj,jk) * ( ptran(ji+1,jj,jk,jn) + ptran(ji+2,jj,jk,jn) ) 169 ENDIF 170 IF( pun(ji-1,jj,jk) < 0. ) THEN 171 zwx(ji-1,jj,jk) = 0.5 * pun(ji-1,jj,jk) * ( ptran(ji-1,jj,jk,jn) + ptran(ji,jj,jk,jn) ) 172 ENDIF 203 173 ENDIF 204 IF( pun(ji-1,jj,jk) < 0. ) THEN 205 zt1(ji-1,jj,jk) = e2u(ji-1,jj) * pun(ji-1,jj,jk) * ( tb(ji-1,jj,jk) + tb(ji ,jj,jk) ) * 0.5 206 zs1(ji-1,jj,jk) = e2u(ji-1,jj) * pun(ji-1,jj,jk) * ( sb(ji-1,jj,jk) + sb(ji ,jj,jk) ) * 0.5 174 IF( vmask(ji,jj,jk) == 0. ) THEN 175 IF( pvn(ji,jj+1,jk) > 0. .AND. jj /= jpj ) THEN 176 zwy(ji,jj+1,jk) = 0.5 * pvn(ji,jj+1,jk) * ( ptran(ji,jj+1,jk,jn) + ptran(ji,jj+2,jk,jn) ) 177 ENDIF 178 IF( pvn(ji,jj-1,jk) < 0. ) THEN 179 zwy(ji,jj-1,jk) = 0.5 * pvn(ji,jj-1,jk) * ( ptran(ji,jj-1,jk,jn) + ptran(ji,jj,jk,jn) ) 180 ENDIF 207 181 ENDIF 208 ENDIF 209 IF( vmask(ji,jj,jk) == 0. ) THEN 210 IF( pvn(ji,jj+1,jk) > 0. .AND. jj /= jpj ) THEN 211 zt2(ji,jj+1,jk) = e1v(ji,jj+1) * pvn(ji,jj+1,jk) * ( tb(ji,jj+1,jk) + tb(ji,jj+2,jk) ) * 0.5 212 zs2(ji,jj+1,jk) = e1v(ji,jj+1) * pvn(ji,jj+1,jk) * ( sb(ji,jj+1,jk) + sb(ji,jj+2,jk) ) * 0.5 182 END DO 183 END DO 184 END DO 185 186 ! ! lateral boundary conditions on zwx, zwy (changed sign) 187 CALL lbc_lnk( zwx, 'U', -1. ) ; CALL lbc_lnk( zwy, 'V', -1. ) 188 ! Tracer flux divergence at t-point added to the general trend 189 DO jk = 1, jpkm1 190 DO jj = 2, jpjm1 191 DO ji = fs_2, fs_jpim1 ! vector opt. 192 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 193 ! horizontal advective trends 194 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 195 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) 196 ! added to the general tracer trends 197 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 198 END DO 199 END DO 200 END DO 201 ! ! trend diagnostics (contribution of upstream fluxes) 202 IF( l_trd ) THEN 203 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptrab(:,:,:,jn) ) 204 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptrab(:,:,:,jn) ) 205 END IF 206 207 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 208 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 209 IF( lk_zco ) THEN 210 DO jk = 1, jpkm1 211 DO jj = 2, jpjm1 212 DO ji = fs_2, fs_jpim1 ! vector opt. 213 zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk) 214 END DO 215 END DO 216 END DO 217 ENDIF 218 IF( jn == jp_tem ) pht_adv(:) = ptr_vj( zwy(:,:,:) ) 219 IF( jn == jp_sal ) pst_adv(:) = ptr_vj( zwy(:,:,:) ) 220 ENDIF 221 222 ! II. Vertical advective fluxes 223 ! ----------------------------- 224 ! !-- first guess of the slopes 225 zwx (:,:, 1 ) = 0.e0 ; zwx (:,:,jpk) = 0.e0 ! surface & bottom boundary conditions 226 DO jk = 2, jpkm1 ! interior values 227 zwx(:,:,jk) = tmask(:,:,jk) * ( ptrab(:,:,jk-1,jn) - ptrab(:,:,jk,jn) ) 228 END DO 229 230 ! !-- Slopes of tracer 231 zslpx(:,:,1) = 0.e0 ! surface values 232 DO jk = 2, jpkm1 ! interior value 233 DO jj = 1, jpj 234 DO ji = 1, jpi 235 zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & 236 & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 237 END DO 238 END DO 239 END DO 240 ! !-- Slopes limitation 241 DO jk = 2, jpkm1 ! interior values 242 DO jj = 1, jpj 243 DO ji = 1, jpi 244 zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN( ABS( zslpx(ji,jj,jk ) ), & 245 & 2.*ABS( zwx (ji,jj,jk+1) ), & 246 & 2.*ABS( zwx (ji,jj,jk ) ) ) 247 END DO 248 END DO 249 END DO 250 ! !-- vertical advective flux 251 ! ! surface values (bottom already set to zero) 252 IF( lk_vvl ) THEN ; zwx(:,:, 1 ) = 0.e0 ! variable volume 253 ELSE ; zwx(:,:, 1 ) = pwn(:,:,1) * ptrab(:,:,1,jn) ! linear free surface 254 ENDIF 255 ! 256 DO jk = 1, jpkm1 ! interior values 257 zdt = z2 * rdttra(jk) 258 DO jj = 2, jpjm1 259 DO ji = fs_2, fs_jpim1 ! vector opt. 260 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3w(ji,jj,jk+1) ) 261 z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 262 zalpha = 0.5 + z0w 263 zw = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr 264 zzwx = ptrab(ji,jj,jk+1,jn) + zw * zslpx(ji,jj,jk+1) 265 zzwy = ptrab(ji,jj,jk ,jn) + zw * zslpx(ji,jj,jk ) 266 zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 267 END DO 268 END DO 269 END DO 270 ! 271 DO jk = 2, jpkm1 ! centered near the bottom 272 DO jj = 2, jpjm1 273 DO ji = fs_2, fs_jpim1 ! vector opt. 274 IF( tmask(ji,jj,jk+1) == 0. ) THEN 275 IF( pwn(ji,jj,jk) > 0. ) THEN 276 zwx(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk-1,jn) + ptran(ji,jj,jk,jn) ) 277 ENDIF 213 278 ENDIF 214 IF( pvn(ji,jj-1,jk) < 0. ) THEN 215 zt2(ji,jj-1,jk) = e1v(ji,jj-1) * pvn(ji,jj-1,jk) * ( tb(ji,jj-1,jk) + tb(ji ,jj,jk) ) * 0.5 216 zs2(ji,jj-1,jk) = e1v(ji,jj-1) * pvn(ji,jj-1,jk) * ( sb(ji,jj-1,jk) + sb(ji ,jj,jk) ) * 0.5 217 ENDIF 218 ENDIF 219 #else 220 IF( umask(ji,jj,jk) == 0. ) THEN 221 IF( pun(ji+1,jj,jk) > 0. .AND. ji /= jpi ) THEN 222 zt1(ji+1,jj,jk) = e2u(ji+1,jj)* fse3u(ji+1,jj,jk) & 223 & * pun(ji+1,jj,jk) * ( tb(ji+1,jj,jk) + tb(ji+2,jj,jk) ) * 0.5 224 zs1(ji+1,jj,jk) = e2u(ji+1,jj)* fse3u(ji+1,jj,jk) & 225 & * pun(ji+1,jj,jk) * ( sb(ji+1,jj,jk) + sb(ji+2,jj,jk) ) * 0.5 226 ENDIF 227 IF( pun(ji-1,jj,jk) < 0. ) THEN 228 zt1(ji-1,jj,jk) = e2u(ji-1,jj)* fse3u(ji-1,jj,jk) & 229 & * pun(ji-1,jj,jk) * ( tb(ji-1,jj,jk) + tb(ji ,jj,jk) ) * 0.5 230 zs1(ji-1,jj,jk) = e2u(ji-1,jj)* fse3u(ji-1,jj,jk) & 231 & * pun(ji-1,jj,jk) * ( sb(ji-1,jj,jk) + sb(ji ,jj,jk) ) * 0.5 232 ENDIF 233 ENDIF 234 IF( vmask(ji,jj,jk) == 0. ) THEN 235 IF( pvn(ji,jj+1,jk) > 0. .AND. jj /= jpj ) THEN 236 zt2(ji,jj+1,jk) = e1v(ji,jj+1) * fse3v(ji,jj+1,jk) & 237 & * pvn(ji,jj+1,jk) * ( tb(ji,jj+1,jk) + tb(ji,jj+2,jk) ) * 0.5 238 zs2(ji,jj+1,jk) = e1v(ji,jj+1) * fse3v(ji,jj+1,jk) & 239 & * pvn(ji,jj+1,jk) * ( sb(ji,jj+1,jk) + sb(ji,jj+2,jk) ) * 0.5 240 ENDIF 241 IF( pvn(ji,jj-1,jk) < 0. ) THEN 242 zt2(ji,jj-1,jk) = e1v(ji,jj-1)* fse3v(ji,jj-1,jk) & 243 & * pvn(ji,jj-1,jk) * ( tb(ji,jj-1,jk) + tb(ji ,jj,jk) ) * 0.5 244 zs2(ji,jj-1,jk) = e1v(ji,jj-1)* fse3v(ji,jj-1,jk) & 245 & * pvn(ji,jj-1,jk) * ( sb(ji,jj-1,jk) + sb(ji ,jj,jk) ) * 0.5 246 ENDIF 247 ENDIF 248 #endif 249 END DO 250 END DO 251 END DO 252 253 ! lateral boundary conditions on zt1, zt2 ; zs1, zs2 (changed sign) 254 CALL lbc_lnk( zt1, 'U', -1. ) ; CALL lbc_lnk( zs1, 'U', -1. ) 255 CALL lbc_lnk( zt2, 'V', -1. ) ; CALL lbc_lnk( zs2, 'V', -1. ) 256 257 ! Compute & add the horizontal advective trend 258 259 DO jk = 1, jpkm1 260 DO jj = 2, jpjm1 261 DO ji = fs_2, fs_jpim1 ! vector opt. 262 #if defined key_zco 263 zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj) ) 264 #else 265 zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 266 #endif 267 ! horizontal advective trends 268 zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj ,jk ) & 269 & + zt2(ji,jj,jk) - zt2(ji ,jj-1,jk ) ) 270 zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj ,jk ) & 271 & + zs2(ji,jj,jk) - zs2(ji ,jj-1,jk ) ) 272 ! add it to the general tracer trends 273 ta(ji,jj,jk) = ta(ji,jj,jk) + zta 274 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 275 END DO 276 END DO 277 END DO 278 279 ! Save the horizontal advective trends for diagnostic 280 IF( l_trdtra ) THEN 281 ztrdt(:,:,:) = 0.e0 ; ztrds(:,:,:) = 0.e0 282 ! 283 ! T/S ZONAL advection trends 279 END DO 280 END DO 281 END DO 282 283 ! Compute & add the vertical advective trend 284 284 DO jk = 1, jpkm1 285 DO jj = 2, jpjm1 286 DO ji = fs_2, fs_jpim1 ! vector opt. 287 !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 288 ! N.B. This computation is not valid along OBCs (if any) 289 #if defined key_zco 290 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 291 z_hdivn_x = ( e2u(ji ,jj) * pun(ji ,jj,jk) & 292 & - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr 293 #else 294 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 295 z_hdivn_x = ( e2u(ji ,jj) * fse3u(ji ,jj,jk) * pun(ji ,jj,jk) & 296 & - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 297 #endif 298 ztrdt(ji,jj,jk) = - zbtr * ( zt1(ji,jj,jk) - zt1(ji-1,jj,jk) ) + tn(ji,jj,jk) * z_hdivn_x 299 ztrds(ji,jj,jk) = - zbtr * ( zs1(ji,jj,jk) - zs1(ji-1,jj,jk) ) + sn(ji,jj,jk) * z_hdivn_x 300 END DO 301 END DO 302 END DO 303 CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 304 305 ! T/S MERIDIONAL advection trends 306 DO jk = 1, jpkm1 307 DO jj = 2, jpjm1 308 DO ji = fs_2, fs_jpim1 ! vector opt. 309 !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 310 ! N.B. This computation is not valid along OBCs (if any) 311 #if defined key_zco 312 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 313 z_hdivn_y = ( e1v(ji,jj ) * pvn(ji,jj ,jk) & 314 & - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr 315 #else 316 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 317 z_hdivn_y = ( e1v(ji, jj) * fse3v(ji,jj ,jk) * pvn(ji,jj ,jk) & 318 & - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 319 #endif 320 ztrdt(ji,jj,jk) = - zbtr * ( zt2(ji,jj,jk) - zt2(ji,jj-1,jk) ) + tn(ji,jj,jk) * z_hdivn_y 321 ztrds(ji,jj,jk) = - zbtr * ( zs2(ji,jj,jk) - zs2(ji,jj-1,jk) ) + sn(ji,jj,jk) * z_hdivn_y 322 END DO 323 END DO 324 END DO 325 CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 326 327 ! Save the up-to-date ta and sa trends 328 ztrdt(:,:,:) = ta(:,:,:) 329 ztrds(:,:,:) = sa(:,:,:) 330 ! 331 ENDIF 332 333 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl2 had - Ta: ', mask1=tmask, & 334 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra') 335 336 ! "zonal" mean advective heat and salt transport 337 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 338 IF( lk_zco ) THEN 339 DO jk = 1, jpkm1 340 DO jj = 2, jpjm1 341 DO ji = fs_2, fs_jpim1 ! vector opt. 342 zt2(ji,jj,jk) = zt2(ji,jj,jk) * fse3v(ji,jj,jk) 343 zs2(ji,jj,jk) = zs2(ji,jj,jk) * fse3v(ji,jj,jk) 344 END DO 345 END DO 346 END DO 347 ENDIF 348 pht_adv(:) = ptr_vj( zt2(:,:,:) ) 349 pst_adv(:) = ptr_vj( zs2(:,:,:) ) 350 ENDIF 351 352 ! II. Vertical advective fluxes 353 ! ----------------------------- 354 355 ! First guess of the slope 356 ! interior values 357 DO jk = 2, jpkm1 358 zt1(:,:,jk) = tmask(:,:,jk) * ( tb(:,:,jk-1) - tb(:,:,jk) ) 359 zs1(:,:,jk) = tmask(:,:,jk) * ( sb(:,:,jk-1) - sb(:,:,jk) ) 360 END DO 361 ! surface & bottom boundary conditions 362 zt1 (:,:, 1 ) = 0.e0 ; zt1 (:,:,jpk) = 0.e0 363 zs1 (:,:, 1 ) = 0.e0 ; zs1 (:,:,jpk) = 0.e0 364 365 ! Slopes 366 DO jk = 2, jpkm1 367 DO jj = 1, jpj 368 DO ji = 1, jpi 369 ztp1(ji,jj,jk) = ( zt1(ji,jj,jk) + zt1(ji,jj,jk+1) ) & 370 & * ( 0.25 + SIGN( 0.25, zt1(ji,jj,jk) * zt1(ji,jj,jk+1) ) ) 371 zsp1(ji,jj,jk) = ( zs1(ji,jj,jk) + zs1(ji,jj,jk+1) ) & 372 & * ( 0.25 + SIGN( 0.25, zs1(ji,jj,jk) * zs1(ji,jj,jk+1) ) ) 373 END DO 374 END DO 375 END DO 376 377 ! Slopes limitation 378 ! interior values 379 DO jk = 2, jpkm1 380 DO jj = 1, jpj 381 DO ji = 1, jpi 382 ztp1(ji,jj,jk) = SIGN( 1., ztp1(ji,jj,jk) ) & 383 & * MIN( ABS( ztp1(ji,jj,jk ) ), & 384 & 2.*ABS( zt1 (ji,jj,jk+1) ), & 385 & 2.*ABS( zt1 (ji,jj,jk ) ) ) 386 zsp1(ji,jj,jk) = SIGN( 1., zsp1(ji,jj,jk) ) & 387 & * MIN( ABS( zsp1(ji,jj,jk ) ), & 388 & 2.*ABS( zs1 (ji,jj,jk+1) ), & 389 & 2.*ABS( zs1 (ji,jj,jk ) ) ) 390 END DO 391 END DO 392 END DO 393 ! surface values 394 ztp1(:,:,1) = 0.e0 395 zsp1(:,:,1) = 0.e0 396 397 ! vertical advective flux 398 ! interior values 399 DO jk = 1, jpkm1 400 zstep = z2 * rdttra(jk) 401 DO jj = 2, jpjm1 402 DO ji = fs_2, fs_jpim1 ! vector opt. 403 zew = pwn(ji,jj,jk+1) 404 z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 405 zalpha = 0.5 + z0w 406 zw = z0w - 0.5 * pwn(ji,jj,jk+1)*zstep / fse3w(ji,jj,jk+1) 407 zzt1 = tb(ji,jj,jk+1) + zw*ztp1(ji,jj,jk+1) 408 zzt2 = tb(ji,jj,jk ) + zw*ztp1(ji,jj,jk ) 409 zzs1 = sb(ji,jj,jk+1) + zw*zsp1(ji,jj,jk+1) 410 zzs2 = sb(ji,jj,jk ) + zw*zsp1(ji,jj,jk ) 411 zt1(ji,jj,jk+1) = zew * ( zalpha * zzt1 + (1.-zalpha)*zzt2 ) 412 zs1(ji,jj,jk+1) = zew * ( zalpha * zzs1 + (1.-zalpha)*zzs2 ) 413 END DO 414 END DO 415 END DO 416 DO jk = 2, jpkm1 417 DO jj = 2, jpjm1 418 DO ji = fs_2, fs_jpim1 ! vector opt. 419 IF( tmask(ji,jj,jk+1) == 0. ) THEN 420 IF( pwn(ji,jj,jk) > 0. ) THEN 421 zt1(ji,jj,jk) = pwn(ji,jj,jk) * ( tb(ji,jj,jk-1) + tb(ji,jj,jk) ) * 0.5 422 zs1(ji,jj,jk) = pwn(ji,jj,jk) * ( sb(ji,jj,jk-1) + sb(ji,jj,jk) ) * 0.5 423 ENDIF 424 ENDIF 425 END DO 426 END DO 427 END DO 428 429 ! surface values 430 IF( lk_vvl ) THEN 431 ! variable volume : flux set to zero 432 zt1(:,:, 1 ) = 0.e0 433 zs1(:,:, 1 ) = 0.e0 434 ELSE 435 ! free surface-constant volume 436 zt1(:,:, 1 ) = pwn(:,:,1) * tb(:,:,1) 437 zs1(:,:, 1 ) = pwn(:,:,1) * sb(:,:,1) 438 ENDIF 439 440 ! bottom values 441 zt1(:,:,jpk) = 0.e0 442 zs1(:,:,jpk) = 0.e0 443 444 445 ! Compute & add the vertical advective trend 446 447 DO jk = 1, jpkm1 448 DO jj = 2, jpjm1 449 DO ji = fs_2, fs_jpim1 ! vector opt. 450 zbtr = 1. / fse3t(ji,jj,jk) 451 ! horizontal advective trends 452 zta = - zbtr * ( zt1(ji,jj,jk) - zt1(ji,jj,jk+1) ) 453 zsa = - zbtr * ( zs1(ji,jj,jk) - zs1(ji,jj,jk+1) ) 454 ! add it to the general tracer trends 455 ta(ji,jj,jk) = ta(ji,jj,jk) + zta 456 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 457 END DO 458 END DO 459 END DO 460 461 ! Save the vertical advective trends for diagnostic 462 IF( l_trdtra ) THEN 463 ! Recompute the vertical advection zta & zsa trends computed 464 ! at the step 2. above in making the difference between the new 465 ! trends and the previous one: ta()/sa - ztrdt()/ztrds() and substract 466 ! the term tn()/sn()*hdivn() to recover the W gradz(T/S) trends 467 468 DO jk = 1, jpkm1 469 DO jj = 2, jpjm1 470 DO ji = fs_2, fs_jpim1 ! vector opt. 471 #if defined key_zco 472 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 473 z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 474 z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 475 #else 476 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 477 z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 478 z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 479 #endif 480 z_hdivn = (z_hdivn_x + z_hdivn_y) * zbtr 481 ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn 482 ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 483 END DO 484 END DO 485 END DO 486 CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 487 ! 488 ENDIF 489 490 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' muscl2 zad - Ta: ', mask1=tmask, & 491 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 285 DO jj = 2, jpjm1 286 DO ji = fs_2, fs_jpim1 ! vector opt. 287 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 288 ! vertical advective trends 289 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) 290 ! added to the general tracer trends 291 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 292 END DO 293 END DO 294 END DO 295 296 ! Save the vertical advective trends for diagnostic 297 ! ------------------------------------------------- 298 ! ! trend diagnostics (contribution of upstream fluxes) 299 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwx, pwn, ptrab(:,:,:,jn) ) 300 ! 301 ENDDO 492 302 ! 493 303 END SUBROUTINE tra_adv_muscl2 -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_qck.F90
r1559 r2024 2 2 !!============================================================================== 3 3 !! *** MODULE traadv_qck *** 4 !! Ocean activetracers: horizontal & vertical advective trend4 !! Ocean tracers: horizontal & vertical advective trend 5 5 !!============================================================================== 6 6 !! History : 3.0 ! 2008-07 (G. Reffray) Original code 7 !! 3.3 ! 2010-05 (C.Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport 7 8 !!---------------------------------------------------------------------- 8 9 … … 16 17 USE oce ! ocean dynamics and active tracers 17 18 USE dom_oce ! ocean space and time domain 18 USE trdmod ! ocean active tracers trends19 USE trd mod_oce ! ocean variables trends19 USE trdmod_oce ! ocean space and time domain 20 USE trdtra ! ocean tracers trends 20 21 USE trabbl ! advective term in the BBL 21 22 USE lib_mpp ! distribued memory computing … … 24 25 USE in_out_manager ! I/O manager 25 26 USE diaptr ! poleward transport diagnostics 26 USE prtctl ! Print control27 27 28 28 IMPLICIT NONE … … 31 31 PUBLIC tra_adv_qck ! routine called by step.F90 32 32 33 REAL(wp) , DIMENSION(jpi,jpj) :: btr234 REAL(wp) :: r1_633 REAL(wp) :: r1_6 = 1./ 6. 34 LOGICAL :: l_trd ! flag to compute trends 35 35 36 36 !! * Substitutions … … 45 45 CONTAINS 46 46 47 SUBROUTINE tra_adv_qck( kt, pun, pvn, pwn ) 47 SUBROUTINE tra_adv_qck ( kt , cdtype, pun , pvn, pwn, & 48 & ptrab, ptran , ptraa, kjpt ) 48 49 !!---------------------------------------------------------------------- 49 50 !! *** ROUTINE tra_adv_qck *** … … 69 70 !! dt = 2*rdtra and the scalar values are tb and sb 70 71 !! 71 !! On the vertical, the simple centered scheme used tn and sn72 !! On the vertical, the simple centered scheme used ptran 72 73 !! 73 74 !! The fluxes are bounded by the ULTIMATE limiter to … … 75 76 !! prevent the appearance of spurious numerical oscillations 76 77 !! 77 !! ** Action : - update ( ta,sa) with the now advective tracer trends78 !! - save the trends ('key_trdtra')78 !! ** Action : - update (ptraa) with the now advective tracer trends 79 !! - save the trends 79 80 !! 80 81 !! ** Reference : Leonard (1979, 1991) 81 82 !!---------------------------------------------------------------------- 82 USE oce, ONLY : ztrdt => ua ! use ua as workspace 83 USE oce, ONLY : ztrds => va ! use va as workspace 84 !! 85 INTEGER , INTENT(in) :: kt ! ocean time-step index 86 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pun ! effective ocean velocity, u_component 87 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvn ! effective ocean velocity, v_component 88 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pwn ! effective ocean velocity, w_component 89 !! 90 INTEGER :: ji, jj, jk ! dummy loop indices 91 REAL(wp) :: z_hdivn_x, z_hdivn_y, z_hdivn ! temporary scalars 92 REAL(wp) :: zbtr, z2 ! " " 83 !!* Arguments 84 INTEGER , INTENT(in ) :: kt ! ocean time-step index 85 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 86 INTEGER , INTENT(in ) :: kjpt ! number of tracers 87 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun, pvn, pwn ! 3 ocean velocity components 88 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab, ptran ! before and now tracer fields 89 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 90 !!* Local declarations 91 REAL(wp) :: z2 ! temporary scalar 93 92 !!---------------------------------------------------------------------- 94 93 … … 98 97 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 99 98 IF(lwp) WRITE(numout,*) 100 btr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 101 r1_6 = 1. / 6. 99 ! 100 l_trd = .FALSE. 101 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 102 102 ENDIF 103 103 … … 109 109 !--------------------------------------------------------------------------- 110 110 111 CALL tra_adv_qck_i( pun, tb, tn, ta, ztrdt, z2) 112 CALL tra_adv_qck_i( pun, sb, sn, sa, ztrds, z2) 113 114 IF( l_trdtra ) CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) 115 116 CALL tra_adv_qck_j( kt, pvn, tb, tn, ta, ztrdt, pht_adv, z2) 117 CALL tra_adv_qck_j( kt, pvn, sb, sn, sa, ztrds, pst_adv, z2) 118 119 IF( l_trdtra ) THEN 120 CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) 121 ! 122 ztrdt(:,:,:) = ta(:,:,:) ! Save the horizontal up-to-date ta/sa trends 123 ztrds(:,:,:) = sa(:,:,:) 124 END IF 125 126 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' qck had - Ta: ', mask1=tmask, & 127 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 111 CALL tra_adv_qck_i( kt , cdtype, pun , z2, & 112 & ptrab, ptran , ptraa, kjpt ) 113 CALL tra_adv_qck_j( kt , cdtype, pvn , z2, & 114 & ptrab, ptran , ptraa, kjpt ) 128 115 129 116 ! II. The vertical fluxes are computed with the 2nd order centered scheme 130 117 !------------------------------------------------------------------------- 131 118 ! 132 CALL tra_adv_cen2_k( pwn, tn, ta ) 133 CALL tra_adv_cen2_k( pwn, sn, sa ) 134 ! 135 !Save the vertical advective trends for diagnostic 136 ! ---------------------------------------------------- 137 IF( l_trdtra ) THEN 138 ! Recompute the vertical advection zta & zsa trends computed 139 ! at the step 2. above in making the difference between the new 140 ! trends and the previous one: ta()/sa - ztrdt()/ztrds() and substract 141 ! the term tn()/sn()*hdivn() to recover the W gradz(T/S) trends 142 143 DO jk = 1, jpkm1 119 CALL tra_adv_cen2_k( kt , cdtype, pwn, & 120 & ptran, ptraa , kjpt ) 121 ! 122 END SUBROUTINE tra_adv_qck 123 124 SUBROUTINE tra_adv_qck_i( kt , cdtype, pun , pz2, & 125 & ptrab, ptran , ptraa, kjpt ) 126 !!---------------------------------------------------------------------- 127 !! 128 !!---------------------------------------------------------------------- 129 !!* Module used 130 USE oce , zwx => ua ! use ua as workspace 131 !!* Arguments 132 INTEGER , INTENT(in ) :: kt ! ocean time-step index 133 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 134 INTEGER , INTENT(in ) :: kjpt ! number of tracers 135 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun ! zonal velocity component 136 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab, ptran ! before tracer fields 137 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 138 REAL(wp) , INTENT(in ) :: pz2 139 !!* Local declarations 140 INTEGER :: ji, jj, jk, jn ! dummy loop indices 141 REAL(wp) :: ztra, zbtr ! temporary scalars 142 REAL(wp) :: zdir, zdx, zdt, zmsk ! temporary scalars 143 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu, zfc, zfd 144 !---------------------------------------------------------------------- 145 146 147 DO jn = 1, kjpt ! tracer loop 148 ! ! =========== 149 zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 150 zfd(:,:,:) = 0.0 ; zwx(:,:,:) = 0.0 151 ! 152 DO jk = 1, jpkm1 153 ! 154 !--- Computation of the ustream and downstream value of the tracer and the mask 144 155 DO jj = 2, jpjm1 145 156 DO ji = fs_2, fs_jpim1 ! vector opt. 146 #if defined key_zco 147 zbtr = btr2(ji,jj) 148 z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 149 z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 150 #else 151 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 152 z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 153 z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 154 #endif 155 z_hdivn = (z_hdivn_x + z_hdivn_y) * zbtr 156 ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn 157 ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn 158 END DO 159 END DO 160 END DO 161 CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) 162 ENDIF 163 164 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' qck zad - Ta: ', mask1=tmask, & 165 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 166 ! 167 END SUBROUTINE tra_adv_qck 168 169 170 SUBROUTINE tra_adv_qck_i ( pun, tra, tran, traa, ztrdtra, z2 ) 171 !!---------------------------------------------------------------------- 172 !! 173 !!---------------------------------------------------------------------- 174 REAL, INTENT(in) :: z2 175 REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pun, tra, tran ! horizontal effective velocity 176 REAL(wp), INTENT(out) , DIMENSION(jpi,jpj,jpk) :: ztrdtra 177 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: traa 178 ! 179 INTEGER :: ji, jj, jk 180 REAL(wp) :: za, zbtr, dir, dx, dt ! temporary scalars 181 REAL(wp) :: z_hdivn_x 182 REAL(wp), DIMENSION(jpi,jpj) :: zmask, zupst, zdwst, zc_cfl 183 REAL(wp), DIMENSION(jpi,jpj) :: zfu, zfc, zfd, zfho, zmskl, zsc_e 184 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zflux 185 !---------------------------------------------------------------------- 186 187 zfu (:,jpj) = 0.e0 ; zfc (:,jpj) = 0.e0 188 zfd (:,jpj) = 0.e0 ; zc_cfl(:,jpj) = 0.e0 189 zsc_e (:,jpj) = 0.e0 ; zmskl (:,jpj) = 0.e0 190 zfho (:,jpj) = 0.e0 191 ! =============== 192 DO jk = 1, jpkm1 ! Horizontal slab 193 ! ! =============== 194 !--- Computation of the ustream and downstream value of the tracer and the mask 195 DO jj = 2, jpjm1 196 DO ji = 2, fs_jpim1 ! vector opt. 197 ! Upstream in the x-direction for the tracer 198 zupst(ji,jj)=tra(ji-1,jj,jk) 199 ! Downstream in the x-direction for the tracer 200 zdwst(ji,jj)=tra(ji+1,jj,jk) 201 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 202 zmask(ji,jj)=tmask(ji-1,jj,jk)+tmask(ji,jj,jk)+tmask(ji+1,jj,jk)-2 203 END DO 204 END DO 205 ! 206 !--- Lateral boundary conditions 207 CALL lbc_lnk( zupst(:,:), 'T', 1. ) 208 CALL lbc_lnk( zdwst(:,:), 'T', 1. ) 209 CALL lbc_lnk( zmask(:,:), 'T', 1. ) 157 ! Upstream in the x-direction for the tracer 158 zfc(ji,jj,jk) = ptrab(ji-1,jj,jk,jn) 159 ! Downstream in the x-direction for the tracer 160 zfd(ji,jj,jk) = ptrab(ji+1,jj,jk,jn) 161 END DO 162 END DO 163 END DO 164 ! 165 !--- Lateral boundary conditions 166 CALL lbc_lnk( zfc(:,:,:), 'T', 1. ) ; CALL lbc_lnk( zfd(:,:,:), 'T', 1. ) 167 210 168 ! 211 169 ! Horizontal advective fluxes 212 170 ! --------------------------- 213 171 ! 214 dt = z2 * rdttra(jk) 215 !--- tracer flux at u-points 216 DO jj = 1, jpjm1 217 DO ji = 1, jpi 218 #if defined key_zco 219 zsc_e(ji,jj) = e2u(ji,jj) 220 #else 221 zsc_e(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) 222 #endif 223 dir = 0.5 + sign(0.5,pun(ji,jj,jk)) ! if pun>0 : dir = 1 otherwise dir = 0 224 dx = dir * e1t(ji,jj) + (1-dir)* e1t(ji+1,jj) 225 zc_cfl (ji,jj) = ABS(pun(ji,jj,jk))*dt/dx ! (0<zc_cfl<1 : Courant number on x-direction) 226 227 zfu(ji,jj) = dir*zupst(ji ,jj )+(1-dir)*zdwst(ji+1,jj ) ! FU in the x-direction for T 228 zfc(ji,jj) = dir*tra (ji ,jj,jk)+(1-dir)*tra (ji+1,jj,jk) ! FC in the x-direction for T 229 zfd(ji,jj) = dir*tra (ji+1,jj,jk)+(1-dir)*tra (ji ,jj,jk) ! FD in the x-direction for T 230 zmskl(ji,jj) = dir*zmask(ji ,jj) +(1-dir)*zmask(ji+1,jj) 231 END DO 232 END DO 233 ! 172 DO jk = 1, jpkm1 173 DO jj = 2, jpjm1 174 DO ji = fs_2, fs_jpim1 ! vector opt. 175 zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 176 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk) ! FU in the x-direction for T 177 END DO 178 END DO 179 END DO 180 ! 181 DO jk = 1, jpkm1 182 zdt = pz2 * rdttra(jk) 183 DO jj = 2, jpjm1 184 DO ji = fs_2, fs_jpim1 ! vector opt. 185 zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 186 zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * fse3u(ji,jj,jk) 187 zwx(ji,jj,jk) = ABS( pun(ji,jj,jk) ) * zdt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) 188 zfc(ji,jj,jk) = zdir * ptrab(ji ,jj,jk,jn) + ( 1. - zdir ) * ptrab(ji+1,jj,jk,jn) ! FC in the x-direction for T 189 zfd(ji,jj,jk) = zdir * ptrab(ji+1,jj,jk,jn) + ( 1. - zdir ) * ptrab(ji ,jj,jk,jn) ! FD in the x-direction for T 190 END DO 191 END DO 192 END DO ! 193 194 !--- Lateral boundary conditions 195 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) ; CALL lbc_lnk( zfd(:,:,:), 'T', 1. ) 196 CALL lbc_lnk( zfc(:,:,:), 'T', 1. ) ; CALL lbc_lnk( zwx(:,:,:), 'T', 1. ) 197 234 198 !--- QUICKEST scheme 199 CALL quickest( zfu, zfd, zfc, zwx ) 200 ! 201 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 202 DO jk = 1, jpkm1 203 DO jj = 2, jpjm1 204 DO ji = fs_2, fs_jpim1 ! vector opt. 205 zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 206 ENDDO 207 END DO 208 END DO 209 !--- Lateral boundary conditions 210 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) 211 ! 235 212 ! Tracer flux on the x-direction 236 CALL quickest(zfu,zfd,zfc,zfho,zc_cfl) 237 !--- If the second ustream point is a land point 238 !--- the flux is computed by the 1st order UPWIND scheme 239 zfho(:,:) = zmskl(:,:)*zfho(:,:) + (1.-zmskl(:,:))*zfc(:,:) 240 !--- Computation of fluxes 241 zflux(:,:,jk) = zsc_e(:,:)*pun(:,:,jk)*zfho(:,:) 242 ! 243 !--- Tracer flux divergence at t-point added to the general trend 244 DO jj = 2, jpjm1 245 DO ji = fs_2, fs_jpim1 ! vector opt. 246 !--- horizontal advective trends 247 #if defined key_zco 248 zbtr = btr2(ji,jj) 249 #else 250 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 251 #endif 252 za = - zbtr * ( zflux(ji,jj,jk) - zflux(ji-1,jj,jk) ) 253 !--- add it to the general tracer trends 254 traa(ji,jj,jk) = traa(ji,jj,jk) + za 255 END DO 256 END DO 257 ! ! =============== 258 END DO ! End of slab 259 ! ! =============== 260 ! 261 ! Save the horizontal advective trends for diagnostic 262 ! ----------------------------------------------------- 263 IF( l_trdtra ) THEN 264 ! T/S ZONAL advection trends 265 ztrdtra(:,:,:) = 0.e0 266 ! 267 DO jk = 1, jpkm1 213 DO jk = 1, jpkm1 214 ! 215 DO jj = 2, jpjm1 216 DO ji = fs_2, fs_jpim1 ! vector opt. 217 zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 218 !--- If the second ustream point is a land point 219 !--- the flux is computed by the 1st order UPWIND scheme 220 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 221 zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 222 zwx(ji,jj,jk) = zwx(ji,jj,jk) * pun(ji,jj,jk) 223 END DO 224 END DO 225 ! 226 ! Computation of the trend 227 DO jj = 2, jpjm1 228 DO ji = fs_2, fs_jpim1 ! vector opt. 229 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 230 ! horizontal advective trends 231 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) 232 !--- add it to the general tracer trends 233 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 234 END DO 235 END DO 236 ! 237 END DO 238 ! ! trend diagnostics (contribution of upstream fluxes) 239 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptran(:,:,:,jn) ) 240 ! 241 END DO 242 ! 243 END SUBROUTINE tra_adv_qck_i 244 245 SUBROUTINE tra_adv_qck_j( kt , cdtype, pvn , pz2, & 246 & ptrab, ptran , ptraa, kjpt ) 247 !!---------------------------------------------------------------------- 248 !! 249 !!---------------------------------------------------------------------- 250 !!* Module used 251 USE oce , zwy => ua ! use ua as workspace 252 !!* Arguments 253 INTEGER , INTENT(in ) :: kt ! ocean time-step index 254 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 255 INTEGER , INTENT(in ) :: kjpt ! number of tracers 256 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pvn ! meridional velocity component 257 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab, ptran ! before tracer fields 258 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 259 REAL(wp) , INTENT(in ) :: pz2 260 !!* Local declarations 261 INTEGER :: ji, jj, jk, jn ! dummy loop indices 262 REAL(wp) :: ztra, zbtr ! temporary scalars 263 REAL(wp) :: zdir, zdx, zdt, zmsk ! temporary scalars 264 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu, zfc, zfd 265 !---------------------------------------------------------------------- 266 267 DO jn = 1, kjpt ! tracer loop 268 ! ! =========== 269 zfu(:,:,:) = 0.0 ; zfc(:,:,:) = 0.0 270 zfd(:,:,:) = 0.0 ; zwy(:,:,:) = 0.0 271 ! 272 DO jk = 1, jpkm1 273 ! 274 !--- Computation of the ustream and downstream value of the tracer and the mask 268 275 DO jj = 2, jpjm1 269 276 DO ji = fs_2, fs_jpim1 ! vector opt. 270 !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 271 ! N.B. This computation is not valid along OBCs (if any) 272 #if defined key_zco 273 zbtr = btr2(ji,jj) 274 z_hdivn_x = ( e2u(ji ,jj) * pun(ji ,jj,jk) & 275 & - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr 276 #else 277 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 278 z_hdivn_x = ( e2u(ji ,jj) * fse3u(ji ,jj,jk) * pun(ji ,jj,jk) & 279 & - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 280 #endif 281 ztrdtra(ji,jj,jk) = - zbtr * ( zflux(ji,jj,jk) - zflux(ji-1,jj,jk) ) + tran(ji,jj,jk) * z_hdivn_x 282 END DO 283 END DO 284 END DO 285 END IF 286 287 END SUBROUTINE tra_adv_qck_i 288 289 290 SUBROUTINE tra_adv_qck_j ( kt, pvn, tra, tran, traa, ztrdtra, trd_adv, z2 ) 291 !!---------------------------------------------------------------------- 292 !! 293 !!---------------------------------------------------------------------- 294 INTEGER, INTENT(in) :: kt ! ocean time-step index 295 REAL, INTENT(in) :: z2 296 REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pvn, tra, tran ! horizontal effective velocity 297 REAL(wp), INTENT(out) , DIMENSION(jpj) :: trd_adv 298 REAL(wp), INTENT(out) , DIMENSION(jpi,jpj,jpk) :: ztrdtra 299 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: traa 300 !! 301 INTEGER :: ji, jj, jk 302 REAL(wp) :: za, zbtr, dir, dx, dt ! temporary scalars 303 REAL(wp) :: z_hdivn_y 304 REAL(wp), DIMENSION(jpi,jpj) :: zmask, zupst, zdwst, zc_cfl 305 REAL(wp), DIMENSION(jpi,jpj) :: zfu, zfc, zfd, zfho, zmskl, zsc_e 306 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zflux 307 !---------------------------------------------------------------------- 308 ! II. Part 2 : y-direction 309 !---------------------------------------------------------------------- 310 311 zfu (:,jpj) = 0.e0 ; zfc (:,jpj) = 0.e0 312 zfd (:,jpj) = 0.e0 ; zc_cfl(:,jpj) = 0.e0 313 zsc_e (:,jpj) = 0.e0 ; zmskl (:,jpj) = 0.e0 314 zfho (:,jpj) = 0.e0 315 316 ! =============== 317 DO jk = 1, jpkm1 ! Horizontal slab 318 ! ! =============== 319 !--- Computation of the ustream and downstream value of the tracer and the mask 320 DO jj = 2, jpjm1 321 DO ji = 2, fs_jpim1 ! vector opt. 322 ! Upstream in the x-direction for the tracer 323 zupst(ji,jj)=tra(ji,jj-1,jk) 324 ! Downstream in the x-direction for the tracer 325 zdwst(ji,jj)=tra(ji,jj+1,jk) 326 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 327 zmask(ji,jj)=tmask(ji,jj-1,jk)+tmask(ji,jj,jk)+tmask(ji,jj+1,jk)-2 328 END DO 329 END DO 330 ! 331 !--- Lateral boundary conditions 332 CALL lbc_lnk( zupst(:,:), 'T', 1. ) 333 CALL lbc_lnk( zdwst(:,:), 'T', 1. ) 334 CALL lbc_lnk( zmask(:,:), 'T', 1. ) 277 ! Upstream in the x-direction for the tracer 278 zfc(ji,jj,jk) = ptrab(ji,jj-1,jk,jn) 279 ! Downstream in the x-direction for the tracer 280 zfd(ji,jj,jk) = ptrab(ji,jj+1,jk,jn) 281 END DO 282 END DO 283 END DO 284 ! 285 !--- Lateral boundary conditions 286 CALL lbc_lnk( zfc(:,:,:), 'T', 1. ) ; CALL lbc_lnk( zfd(:,:,:), 'T', 1. ) 287 335 288 ! 336 289 ! Horizontal advective fluxes 337 290 ! --------------------------- 338 291 ! 339 dt = z2 * rdttra(jk) 340 !--- tracer flux at v-points 341 DO jj = 1, jpjm1 292 DO jk = 1, jpkm1 293 DO jj = 2, jpjm1 294 DO ji = fs_2, fs_jpim1 ! vector opt. 295 zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 296 zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk) ! FU in the x-direction for T 297 END DO 298 END DO 299 END DO 300 ! 301 DO jk = 1, jpkm1 302 zdt = pz2 * rdttra(jk) 303 DO jj = 2, jpjm1 304 DO ji = fs_2, fs_jpim1 ! vector opt. 305 zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 306 zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * fse3v(ji,jj,jk) 307 zwy(ji,jj,jk) = ABS( pvn(ji,jj,jk) ) * zdt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) 308 zfc(ji,jj,jk) = zdir * ptrab(ji,jj ,jk,jn) + ( 1. - zdir ) * ptrab(ji,jj+1,jk,jn) ! FC in the x-direction for T 309 zfd(ji,jj,jk) = zdir * ptrab(ji,jj+1,jk,jn) + ( 1. - zdir ) * ptrab(ji,jj ,jk,jn) ! FD in the x-direction for T 310 END DO 311 END DO 312 END DO ! 313 314 !--- Lateral boundary conditions 315 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) ; CALL lbc_lnk( zfd(:,:,:), 'T', 1. ) 316 CALL lbc_lnk( zfc(:,:,:), 'T', 1. ) ; CALL lbc_lnk( zwy(:,:,:), 'T', 1. ) 317 318 !--- QUICKEST scheme 319 CALL quickest( zfu, zfd, zfc, zwy ) 320 ! 321 ! Mask at the T-points in the x-direction (mask=0 or mask=1) 322 DO jk = 1, jpkm1 323 DO jj = 2, jpjm1 324 DO ji = fs_2, fs_jpim1 ! vector opt. 325 zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 326 ENDDO 327 END DO 328 END DO 329 !--- Lateral boundary conditions 330 CALL lbc_lnk( zfu(:,:,:), 'T', 1. ) 331 ! 332 ! Tracer flux on the x-direction 333 DO jk = 1, jpkm1 334 ! 335 DO jj = 2, jpjm1 336 DO ji = fs_2, fs_jpim1 ! vector opt. 337 zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 338 !--- If the second ustream point is a land point 339 !--- the flux is computed by the 1st order UPWIND scheme 340 zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 341 zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 342 zwy(ji,jj,jk) = zwy(ji,jj,jk) * pvn(ji,jj,jk) 343 END DO 344 END DO 345 ! 346 ! Computation of the trend 347 DO jj = 2, jpjm1 348 DO ji = fs_2, fs_jpim1 ! vector opt. 349 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 350 ! horizontal advective trends 351 ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) 352 !--- add it to the general tracer trends 353 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 354 END DO 355 END DO 356 ! 357 END DO 358 ! ! trend diagnostics (contribution of upstream fluxes) 359 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptran(:,:,:,jn) ) 360 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 361 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 362 IF( jn == jp_tem ) pht_adv(:) = ptr_vj( zwy(:,:,:) ) 363 IF( jn == jp_sal ) pst_adv(:) = ptr_vj( zwy(:,:,:) ) 364 ENDIF 365 ! 366 END DO 367 368 END SUBROUTINE tra_adv_qck_j 369 370 SUBROUTINE tra_adv_cen2_k( kt , cdtype, pwn, & 371 & ptran, ptraa , kjpt ) 372 !!---------------------------------------------------------------------- 373 !! 374 !!---------------------------------------------------------------------- 375 !!* Module used 376 USE oce , zwz => ua ! use ua as workspace 377 !!* Arguments 378 INTEGER , INTENT(in ) :: kt ! ocean time-step index 379 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 380 INTEGER , INTENT(in ) :: kjpt ! number of tracers 381 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pwn ! vertical velocity component 382 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptran ! now tracer field 383 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 384 !!* Local declarations 385 INTEGER :: ji, jj, jk, jn ! dummy loop indices 386 REAL(wp) :: zbtr , ztra ! temporary scalars 387 !!---------------------------------------------------------------------- 388 389 ! 390 DO jn = 1, kjpt ! tracer loop 391 ! ! =========== 392 ! 1. Bottom value : flux set to zero 393 zwz(:,:,jpk) = 0.e0 ! Bottom value : flux set to zero 394 ! 395 ! ! Surface value 396 IF( lk_vvl ) THEN ; zwz(:,:, 1 ) = 0.e0 ! Variable volume : flux set to zero 397 ELSE ; zwz(:,:, 1 ) = pwn(:,:,1) * ptran(:,:,1,jn) ! Constant volume : advective flux through the surface 398 ENDIF 399 ! 400 DO jk = 2, jpkm1 ! Interior point: second order centered tracer flux at w-point 401 DO jj = 2, jpjm1 402 DO ji = fs_2, fs_jpim1 ! vector opt. 403 zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk-1,jn) + ptran(ji,jj,jk,jn) ) 404 END DO 405 END DO 406 END DO 407 ! 408 DO jk = 1, jpkm1 !== Tracer flux divergence added to the general trend ==! 409 DO jj = 2, jpjm1 410 DO ji = fs_2, fs_jpim1 ! vector opt. 411 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 412 ! k- vertical advective trends 413 ztra = - zbtr * ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) 414 ! added to the general tracer trends 415 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 416 END DO 417 END DO 418 END DO 419 ! ! Save the vertical advective trends for diagnostic 420 IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zwz, pwn, ptran(:,:,:,jn) ) 421 ! 422 END DO 423 ! 424 END SUBROUTINE tra_adv_cen2_k 425 426 427 SUBROUTINE quickest( pfu, pfd, pfc, puc ) 428 !!---------------------------------------------------------------------- 429 !! 430 !! ** Purpose : Computation of advective flux with Quickest scheme 431 !! 432 !! ** Method : 433 !!---------------------------------------------------------------------- 434 REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pfu ! second upwind point 435 REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pfd ! first douwning point 436 REAL(wp), INTENT(in) , DIMENSION(jpi,jpj,jpk) :: pfc ! the central point (or the first upwind point) 437 REAL(wp), INTENT(inout) , DIMENSION(jpi,jpj,jpk) :: puc ! input as Courant number ; output as flux 438 !! 439 INTEGER :: ji, jj, jk ! dummy loop indices 440 REAL(wp) :: zcoef1, zcoef2, zcoef3 ! temporary scalars 441 REAL(wp) :: zc, zcurv, zfho ! 442 !---------------------------------------------------------------------- 443 444 DO jk = 1, jpkm1 445 DO jj = 1, jpj 342 446 DO ji = 1, jpi 343 #if defined key_zco 344 zsc_e(ji,jj) = e1v(ji,jj) 345 #else 346 zsc_e(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) 347 #endif 348 dir = 0.5 + sign(0.5,pvn(ji,jj,jk)) ! if pvn>0 : dir = 1 otherwise dir = 0 349 dx = dir * e2t(ji,jj) + (1-dir)* e2t(ji,jj+1) 350 zc_cfl(ji,jj) = ABS(pvn(ji,jj,jk))*dt/dx ! (0<zc_cfl<1 : Courant number on y-direction) 351 352 zfu(ji,jj) = dir*zupst(ji,jj )+(1-dir)*zdwst(ji,jj+1 ) ! FU in the y-direction for T 353 zfc(ji,jj) = dir*tra (ji,jj ,jk)+(1-dir)*tra (ji,jj+1,jk) ! FC in the y-direction for T 354 zfd(ji,jj) = dir*tra (ji,jj+1,jk)+(1-dir)*tra (ji,jj ,jk) ! FD in the y-direction for T 355 zmskl(ji,jj) = dir*zmask(ji,jj )+(1-dir)*zmask(ji,jj+1) 356 END DO 357 END DO 358 ! 359 !--- QUICKEST scheme 360 ! Tracer flux on the y-direction 361 CALL quickest(zfu,zfd,zfc,zfho,zc_cfl) 362 !--- If the second ustream point is a land point 363 !--- the flux is computed by the 1st order UPWIND scheme 364 zfho(:,:) = zmskl(:,:)*zfho(:,:) + (1.-zmskl(:,:))*zfc(:,:) 365 !--- Computation of fluxes 366 zflux(:,:,jk) = zsc_e(:,:)*pvn(:,:,jk)*zfho(:,:) 367 ! 368 !--- Tracer flux divergence at t-point added to the general trend 369 DO jj = 2, jpjm1 370 DO ji = fs_2, fs_jpim1 ! vector opt. 371 !--- horizontal advective trends 372 #if defined key_zco 373 zbtr = btr2(ji,jj) 374 #else 375 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 376 #endif 377 za = - zbtr * ( zflux(ji,jj,jk) - zflux(ji,jj-1,jk) ) 378 !--- add it to the general tracer trends 379 traa(ji,jj,jk) = traa(ji,jj,jk) + za 380 END DO 381 END DO 382 ! ! =============== 383 END DO ! End of slab 384 ! ! =============== 385 ! 386 ! Save the horizontal advective trends for diagnostic 387 ! ----------------------------------------------------- 388 IF( l_trdtra ) THEN 389 ! T/S MERIDIONAL advection trends 390 DO jk = 1, jpkm1 391 DO jj = 2, jpjm1 392 DO ji = fs_2, fs_jpim1 ! vector opt. 393 !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 394 ! N.B. This computation is not valid along OBCs (if any) 395 #if defined key_zco 396 zbtr = btr2(ji,jj) 397 z_hdivn_y = ( e1v(ji,jj ) * pvn(ji,jj ,jk) & 398 & - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr 399 #else 400 zbtr = btr2(ji,jj) / fse3t(ji,jj,jk) 401 z_hdivn_y = ( e1v(ji, jj) * fse3v(ji,jj ,jk) * pvn(ji,jj ,jk) & 402 & - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 403 #endif 404 ztrdtra(ji,jj,jk) = - zbtr * ( zflux(ji,jj,jk) - zflux(ji,jj-1,jk) ) + tran(ji,jj,jk) * z_hdivn_y 405 END DO 406 END DO 407 END DO 408 END IF 409 410 ! "zonal" mean advective heat and salt transport 411 ! ---------------------------------------------- 412 413 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 414 IF( lk_zco ) THEN 415 DO jk = 1, jpkm1 416 DO jj = 2, jpjm1 417 DO ji = fs_2, fs_jpim1 ! vector opt. 418 zflux(ji,jj,jk) = zflux(ji,jj,jk) * fse3v(ji,jj,jk) 419 END DO 420 END DO 421 END DO 422 ENDIF 423 trd_adv(:) = ptr_vj( zflux(:,:,:) ) 424 ENDIF 425 426 END SUBROUTINE tra_adv_qck_j 427 428 429 SUBROUTINE tra_adv_cen2_k ( pwn, ptn, pta ) 430 !!---------------------------------------------------------------------- 431 !! 432 !!---------------------------------------------------------------------- 433 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pwn ! vertical effective velocity 434 REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk) :: ptn ! now tracer 435 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) :: pta ! tracer general trend 436 !! 437 INTEGER :: ji, jj, jk ! dummy loop indices 438 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zflux ! 3D workspace 439 !!---------------------------------------------------------------------- 440 ! 441 ! !== Vertical advective fluxes ==! 442 zflux(:,:,jpk) = 0.e0 ! Bottom value : flux set to zero 443 ! 444 ! ! Surface value 445 IF( lk_vvl ) THEN ; zflux(:,:, 1 ) = 0.e0 ! Variable volume : flux set to zero 446 ELSE ; zflux(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1) ! Constant volume : advective flux through the surface 447 ENDIF 448 ! 449 DO jk = 2, jpkm1 ! Interior point: second order centered tracer flux at w-point 450 DO jj = 2, jpjm1 451 DO ji = fs_2, fs_jpim1 ! vector opt. 452 zflux(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1) + ptn(ji,jj,jk) ) 453 END DO 454 END DO 455 END DO 456 ! 457 DO jk = 1, jpkm1 !== Tracer flux divergence added to the general trend ==! 458 DO jj = 2, jpjm1 459 DO ji = fs_2, fs_jpim1 ! vector opt. 460 pta(ji,jj,jk) = pta(ji,jj,jk) - ( zflux(ji,jj,jk) - zflux(ji,jj,jk+1) ) & 461 & / fse3t(ji,jj,jk) 462 END DO 463 END DO 464 END DO 465 ! 466 END SUBROUTINE tra_adv_cen2_k 467 468 469 SUBROUTINE quickest( fu, fd, fc, fho, fc_cfl ) 470 !!---------------------------------------------------------------------- 471 !! 472 !!---------------------------------------------------------------------- 473 REAL(wp), INTENT(in) , DIMENSION(jpi,jpj) :: fu, fd, fc, fc_cfl 474 REAL(wp), INTENT(out) , DIMENSION(jpi,jpj) :: fho 475 REAL(wp) , DIMENSION(jpi,jpj) :: zcurv, zcoef1, zcoef2, zcoef3 ! temporary scalars 476 ! 477 zcurv (:,:) = fd(:,:) + fu(:,:) - 2.*fc(:,:) 478 zcoef1(:,:) = 0.5*( fc(:,:) + fd(:,:) ) 479 zcoef2(:,:) = 0.5*fc_cfl(:,:)*( fd(:,:) - fc(:,:) ) 480 zcoef3(:,:) = ( ( 1. - ( fc_cfl(:,:)*fc_cfl(:,:) ) )*r1_6 )*zcurv(:,:) 481 fho (:,:) = zcoef1(:,:) - zcoef2(:,:) - zcoef3(:,:) ! phi_f QUICKEST 482 ! 483 zcoef1(:,:) = fd(:,:) - fu(:,:) ! DEL 484 zcoef2(:,:) = ABS( zcoef1(:,:) ) ! ABS(DEL) 485 zcoef3(:,:) = ABS( zcurv(:,:) ) ! ABS(CURV) 486 ! 487 WHERE ( zcoef3(:,:) >= zcoef2(:,:) ) 488 fho(:,:) = fc(:,:) 489 ELSEWHERE 490 zcoef3(:,:) = fu(:,:) + ( ( fc(:,:) - fu(:,:) )/MAX(fc_cfl(:,:),1.e-9) ) ! phi_REF 491 WHERE ( zcoef1(:,:) >= 0.e0 ) 492 fho(:,:) = MAX(fc(:,:),fho(:,:)) 493 fho(:,:) = MIN(fho(:,:),MIN(zcoef3(:,:),fd(:,:))) 494 ELSEWHERE 495 fho(:,:) = MIN(fc(:,:),fho(:,:)) 496 fho(:,:) = MAX(fho(:,:),MAX(zcoef3(:,:),fd(:,:))) 497 ENDWHERE 498 ENDWHERE 447 zc = puc(ji,jj,jk) ! Courant number 448 zcurv = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 449 zcoef1 = 0.5 * ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) 450 zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 451 zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 452 zfho = zcoef1 - zcoef2 - zcoef3 ! phi_f QUICKEST 453 ! 454 zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) 455 zcoef2 = ABS( zcoef1 ) 456 zcoef3 = ABS( zcurv ) 457 IF( zcoef3 >= zcoef2 ) THEN 458 zfho = pfc(ji,jj,jk) 459 ELSE 460 zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) ) ! phi_REF 461 IF( zcoef1 >= 0. ) THEN 462 zfho = MAX( pfc(ji,jj,jk), zfho ) 463 zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) ) 464 ELSE 465 zfho = MIN( pfc(ji,jj,jk), zfho ) 466 zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) ) 467 ENDIF 468 ENDIF 469 puc(ji,jj,jk) = zfho 470 ENDDO 471 ENDDO 472 ENDDO 499 473 ! 500 474 END SUBROUTINE quickest -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r1970 r2024 2 2 !!============================================================================== 3 3 !! *** MODULE traadv_tvd *** 4 !! Ocean activetracers: horizontal & vertical advective trend4 !! Ocean tracers: horizontal & vertical advective trend 5 5 !!============================================================================== 6 6 !! History : ! 95-12 (L. Mortier) Original code … … 8 8 !! ! 00-10 (MA Foujols E.Kestenare) include file not routine 9 9 !! ! 00-12 (E. Kestenare M. Levy) fix bug in trtrd indexes 10 !! ! 01-07 (E. Durand G. Madec) adapt ation to ORCA config10 !! ! 01-07 (E. Durand G. Madec) adaptraation to ORCA config 11 11 !! 8.5 ! 02-06 (G. Madec) F90: Free form and module 12 12 !! 9.0 ! 04-01 (A. de Miranda, G. Madec, J.M. Molines ): advective bbl 13 13 !! 9.0 ! 08-04 (S. Cravatte) add the i-, j- & k- trends computation 14 !! " " ! 05-11 (V. Garnier) Surface pressure gradient organization 14 !! " " ! 09-11 (V. Garnier) Surface pressure gradient organization 15 !! 3.3 ! 10-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport 15 16 !!---------------------------------------------------------------------- 16 17 … … 24 25 USE oce ! ocean dynamics and active tracers 25 26 USE dom_oce ! ocean space and time domain 26 USE trdmod ! ocean active tracers trends27 USE trd mod_oce ! ocean variables trends27 USE trdmod_oce ! tracers trends 28 USE trdtra ! tracers trends 28 29 USE in_out_manager ! I/O manager 29 30 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 30 USE trabbl ! Advective term of BBL31 31 USE lib_mpp 32 32 USE lbclnk ! ocean lateral boundary condition (or mpp link) 33 33 USE diaptr ! poleward transport diagnostics 34 USE prtctl ! Print control35 34 36 35 … … 39 38 40 39 PUBLIC tra_adv_tvd ! routine called by step.F90 40 41 LOGICAL :: l_trd ! flag to compute trends 41 42 42 43 !! * Substitutions … … 51 52 CONTAINS 52 53 53 SUBROUTINE tra_adv_tvd( kt, pun, pvn, pwn ) 54 SUBROUTINE tra_adv_tvd ( kt , cdtype, pun , pvn, pwn, & 55 & ptrab, ptran , ptraa, kjpt ) 54 56 !!---------------------------------------------------------------------- 55 57 !! *** ROUTINE tra_adv_tvd *** … … 62 64 !! note: - this advection scheme needs a leap-frog time scheme 63 65 !! 64 !! ** Action : - update ( ta,sa) with the now advective tracer trends65 !! - save the trends in (ztrdt,ztrds) ('key_trdtra')66 !!---------------------------------------------------------------------- 67 USE oce , ztrdt => ua ! use ua as workspace68 USE oce , ztrds => va ! use va as workspace69 !!70 INTEGER , INTENT(in) :: kt ! ocean time-step index71 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pun ! ocean velocity u-component72 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvn ! ocean velocity v-component73 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pwn ! ocean velocity w-component74 !!75 INTEGER :: ji, jj, jk ! dummy loop indices76 REAL(wp) :: & ! temporary scalar77 ztat, zsat, & ! " "78 z_hdivn_x, z_hdivn_y, z_hdivn66 !! ** Action : - update (ptraa) with the now advective tracer trends 67 !! - save the trends 68 !!---------------------------------------------------------------------- 69 !!* Module used 70 USE oce , zwx => ua ! use ua as workspace 71 USE oce , zwy => va ! use va as workspace 72 !!* Arguments 73 INTEGER , INTENT(in ) :: kt ! ocean time-step index 74 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 75 INTEGER , INTENT(in ) :: kjpt ! number of tracers 76 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun, pvn, pwn ! 3 ocean velocity components 77 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab, ptran ! before and now tracer fields 78 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 79 !!* Local declarations 80 INTEGER :: ji, jj, jk, jn ! dummy loop indices 79 81 REAL(wp) :: & 80 z2dtt, zbtr, zeu, zev, & ! temporary scalar 81 zew, z2, zbtr1, & ! temporary scalar 82 zfp_ui, zfp_vj, zfp_wk, & ! " " 83 zfm_ui, zfm_vj, zfm_wk ! " " 84 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zti, ztu, ztv, ztw ! temporary workspace 85 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zsi, zsu, zsv, zsw ! " " 86 !!---------------------------------------------------------------------- 87 88 zti(:,:,:) = 0.e0 ; zsi(:,:,:) = 0.e0 82 z2, z2dtt, zbtr, ztra, & ! temporary scalar 83 zfp_ui, zfp_vj, zfp_wk, & ! " " 84 zfm_ui, zfm_vj, zfm_wk ! " " 85 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zwi, zwz ! temporary workspace 86 REAL(wp), DIMENSION (:,:,:), ALLOCATABLE :: ztrdx, ztrdy, ztrdz 87 !!---------------------------------------------------------------------- 88 89 zwi(:,:,:) = 0.e0 89 90 90 91 IF( kt == nit000 .AND. lwp ) THEN … … 92 93 WRITE(numout,*) 'tra_adv_tvd : TVD advection scheme' 93 94 WRITE(numout,*) '~~~~~~~~~~~' 95 ! 96 l_trd = .FALSE. 97 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 94 98 ENDIF 95 99 ! 100 IF( l_trd ) THEN 101 ALLOCATE( ztrdx(jpi,jpj,jpk) ) ; ztrdx(:,:,:) = 0. 102 ALLOCATE( ztrdy(jpi,jpj,jpk) ) ; ztrdy(:,:,:) = 0. 103 ALLOCATE( ztrdz(jpi,jpj,jpk) ) ; ztrdz(:,:,:) = 0. 104 END IF 105 ! 96 106 IF( neuler == 0 .AND. kt == nit000 ) THEN ; z2 = 1. 97 107 ELSE ; z2 = 2. 98 108 ENDIF 99 100 ! 1. Bottom value : flux set to zero 101 ! --------------- 102 ztu(:,:,jpk) = 0.e0 ; zsu(:,:,jpk) = 0.e0 103 ztv(:,:,jpk) = 0.e0 ; zsv(:,:,jpk) = 0.e0 104 ztw(:,:,jpk) = 0.e0 ; zsw(:,:,jpk) = 0.e0 105 zti(:,:,jpk) = 0.e0 ; zsi(:,:,jpk) = 0.e0 106 107 108 ! 2. upstream advection with initial mass fluxes & intermediate update 109 ! -------------------------------------------------------------------- 110 ! upstream tracer flux in the i and j direction 111 DO jk = 1, jpkm1 112 DO jj = 1, jpjm1 113 DO ji = 1, fs_jpim1 ! vector opt. 114 zeu = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 115 zev = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 116 ! upstream scheme 117 zfp_ui = zeu + ABS( zeu ) 118 zfm_ui = zeu - ABS( zeu ) 119 zfp_vj = zev + ABS( zev ) 120 zfm_vj = zev - ABS( zev ) 121 ztu(ji,jj,jk) = zfp_ui * tb(ji,jj,jk) + zfm_ui * tb(ji+1,jj ,jk) 122 ztv(ji,jj,jk) = zfp_vj * tb(ji,jj,jk) + zfm_vj * tb(ji ,jj+1,jk) 123 zsu(ji,jj,jk) = zfp_ui * sb(ji,jj,jk) + zfm_ui * sb(ji+1,jj ,jk) 124 zsv(ji,jj,jk) = zfp_vj * sb(ji,jj,jk) + zfm_vj * sb(ji ,jj+1,jk) 125 END DO 126 END DO 127 END DO 128 129 ! upstream tracer flux in the k direction 130 ! Surface value 131 IF( lk_vvl ) THEN 132 ! variable volume : flux set to zero 133 ztw(:,:,1) = 0.e0 134 zsw(:,:,1) = 0.e0 135 ELSE 136 ! free surface-constant volume 137 DO jj = 1, jpj 138 DO ji = 1, jpi 139 zew = e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,1) 140 ztw(ji,jj,1) = zew * tb(ji,jj,1) 141 zsw(ji,jj,1) = zew * sb(ji,jj,1) 142 END DO 143 END DO 144 ENDIF 145 146 ! Interior value 147 DO jk = 2, jpkm1 148 DO jj = 1, jpj 149 DO ji = 1, jpi 150 zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk) 151 zfp_wk = zew + ABS( zew ) 152 zfm_wk = zew - ABS( zew ) 153 ztw(ji,jj,jk) = zfp_wk * tb(ji,jj,jk) + zfm_wk * tb(ji,jj,jk-1) 154 zsw(ji,jj,jk) = zfp_wk * sb(ji,jj,jk) + zfm_wk * sb(ji,jj,jk-1) 155 END DO 156 END DO 157 END DO 158 159 ! total advective trend 160 DO jk = 1, jpkm1 161 z2dtt = z2 * rdttra(jk) 162 DO jj = 2, jpjm1 163 DO ji = fs_2, fs_jpim1 ! vector opt. 164 zbtr = 1./ ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 165 ! total intermediate advective trends 166 ztat = - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk ) & 167 & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk ) & 168 & + ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) * zbtr 169 zsat = - ( zsu(ji,jj,jk) - zsu(ji-1,jj ,jk ) & 170 & + zsv(ji,jj,jk) - zsv(ji ,jj-1,jk ) & 171 & + zsw(ji,jj,jk) - zsw(ji ,jj ,jk+1) ) * zbtr 172 ! update and guess with monotonic sheme 173 ta(ji,jj,jk) = ta(ji,jj,jk) + ztat 174 sa(ji,jj,jk) = sa(ji,jj,jk) + zsat 175 zti (ji,jj,jk) = ( tb(ji,jj,jk) + z2dtt * ztat ) * tmask(ji,jj,jk) 176 zsi (ji,jj,jk) = ( sb(ji,jj,jk) + z2dtt * zsat ) * tmask(ji,jj,jk) 177 END DO 178 END DO 179 END DO 180 181 ! "zonal" mean advective heat and salt transport 182 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 183 pht_adv(:) = ptr_vj( ztv(:,:,:) ) 184 pst_adv(:) = ptr_vj( zsv(:,:,:) ) 185 ENDIF 186 187 ! Save the intermediate i / j / k advective trends for diagnostics 188 ! ------------------------------------------------------------------- 189 ! Warning : We should use zun instead of un in the computations below, but we 190 ! also use hdivn which is computed with un, vn (check ???). So we use un, vn 191 ! for consistency. Results are therefore approximate with key_trabbl_adv. 192 193 IF( l_trdtra ) THEN 194 ztrdt(:,:,:) = 0.e0 ; ztrds(:,:,:) = 0.e0 195 ! 196 ! T/S ZONAL advection trends 109 ! 110 ! ! =========== 111 DO jn = 1, kjpt ! tracer loop 112 ! ! =========== 113 ! 1. Bottom value : flux set to zero 114 ! ---------------------------------- 115 zwx(:,:,jpk) = 0.e0 ; zwz(:,:,jpk) = 0.e0 116 zwy(:,:,jpk) = 0.e0 ; zwi(:,:,jpk) = 0.e0 117 118 ! 2. upstream advection with initial mass fluxes & intermediate update 119 ! -------------------------------------------------------------------- 120 ! upstream tracer flux in the i and j direction 197 121 DO jk = 1, jpkm1 122 DO jj = 1, jpjm1 123 DO ji = 1, fs_jpim1 ! vector opt. 124 ! upstream scheme 125 zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 126 zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 127 zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 128 zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 129 zwx(ji,jj,jk) = 0.5 * ( zfp_ui * ptrab(ji,jj,jk,jn) + zfm_ui * ptrab(ji+1,jj ,jk,jn) ) 130 zwy(ji,jj,jk) = 0.5 * ( zfp_vj * ptrab(ji,jj,jk,jn) + zfm_vj * ptrab(ji ,jj+1,jk,jn) ) 131 END DO 132 END DO 133 END DO 134 135 ! upstream tracer flux in the k direction 136 ! Surface value 137 IF( lk_vvl ) THEN ; zwz(:,:, 1 ) = 0.e0 ! volume variable 138 ELSE ; zwz(:,:, 1 ) = pwn(:,:,1) * ptrab(:,:,1,jn) ! linear free surface 139 ENDIF 140 ! Interior value 141 DO jk = 2, jpkm1 142 DO jj = 1, jpj 143 DO ji = 1, jpi 144 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 145 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 146 zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptrab(ji,jj,jk,jn) + zfm_wk * ptrab(ji,jj,jk-1,jn) ) 147 END DO 148 END DO 149 END DO 150 151 ! total advective trend 152 DO jk = 1, jpkm1 153 z2dtt = z2 * rdttra(jk) 198 154 DO jj = 2, jpjm1 199 155 DO ji = fs_2, fs_jpim1 ! vector opt. 200 156 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 201 ztrdt(ji,jj,jk) = - ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zbtr 202 ztrds(ji,jj,jk) = - ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) ) * zbtr 203 END DO 204 END DO 205 END DO 206 CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) ! save the trends 207 ! 208 ! T/S MERIDIONAL advection trends 157 ! total intermediate advective trends 158 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 159 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 160 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) 161 ! update and guess with monotonic sheme 162 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 163 zwi(ji,jj,jk) = ( ptrab(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 164 END DO 165 END DO 166 END DO 167 ! ! Lateral boundary conditions on zwi (unchanged sign) 168 CALL lbc_lnk( zwi, 'T', 1. ) 169 170 ! ! trend diagnostics (contribution of upstream fluxes) 171 IF( l_trd ) THEN 172 ! store intermediate advective trends 173 ztrdx(:,:,:) = zwx(:,:,:) ; ztrdy(:,:,:) = zwy(:,:,:) ; ztrdz(:,:,:) = zwz(:,:,:) 174 END IF 175 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 176 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 177 IF( jn == jp_tem ) pht_adv(:) = ptr_vj( zwy(:,:,:) ) 178 IF( jn == jp_sal ) pst_adv(:) = ptr_vj( zwy(:,:,:) ) 179 ENDIF 180 181 ! 3. antidiffusive flux : high order minus low order 182 ! -------------------------------------------------- 183 ! antidiffusive flux on i and j 184 DO jk = 1, jpkm1 185 DO jj = 1, jpjm1 186 DO ji = 1, fs_jpim1 ! vector opt. 187 zwx(ji,jj,jk) = 0.5 * pun(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk) 188 zwy(ji,jj,jk) = 0.5 * pvn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj+1,jk,jn) ) - zwy(ji,jj,jk) 189 END DO 190 END DO 191 END DO 192 193 ! antidiffusive flux on k 194 ! Surface value 195 zwz(:,:,1) = 0.e0 196 ! Interior value 197 DO jk = 2, jpkm1 198 DO jj = 1, jpj 199 DO ji = 1, jpi 200 zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 201 END DO 202 END DO 203 END DO 204 205 ! Lateral bondary conditions 206 CALL lbc_lnk( zwx, 'U', -1. ) 207 CALL lbc_lnk( zwy, 'V', -1. ) 208 CALL lbc_lnk( zwz, 'W', 1. ) 209 210 ! 4. monotonicity algorithm 211 ! ------------------------- 212 CALL nonosc( ptrab(:,:,:,jn), zwx, zwy, zwz, zwi, z2 ) 213 214 215 ! 5. final trend with corrected fluxes 216 ! ------------------------------------ 209 217 DO jk = 1, jpkm1 210 218 DO jj = 2, jpjm1 211 DO ji = fs_2, fs_jpim1 ! vector opt. 212 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 213 ztrdt(ji,jj,jk) = - ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zbtr 214 ztrds(ji,jj,jk) = - ( zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) * zbtr 215 END DO 216 END DO 217 END DO 218 CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) ! save the trends 219 DO ji = fs_2, fs_jpim1 ! vector opt. 220 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 221 ! total advective trends 222 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 223 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 224 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) 225 ! add them to the general tracer trends 226 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 227 END DO 228 END DO 229 END DO 230 231 ! ! trend diagnostics (contribution of upstream fluxes) 232 IF( l_trd ) THEN 233 ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:) ! <<< Add to previously computed 234 ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:) ! <<< Add to previously computed 235 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 236 237 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, ztrdx, pun, ptran(:,:,:,jn) ) 238 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, ztrdy, pvn, ptran(:,:,:,jn) ) 239 CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, ztrdz, pwn, ptran(:,:,:,jn) ) 240 END IF 241 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 242 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 243 IF( jn == jp_tem ) pht_adv(:) = ptr_vj( zwy(:,:,:) ) + pht_adv(:) 244 IF( jn == jp_sal ) pst_adv(:) = ptr_vj( zwy(:,:,:) ) + pst_adv(:) 245 ENDIF 219 246 ! 220 ! T/S VERTICAL advection trends 221 DO jk = 1, jpkm1 222 DO jj = 2, jpjm1 223 DO ji = fs_2, fs_jpim1 ! vector opt. 224 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 225 ztrdt(ji,jj,jk) = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 226 ztrds(ji,jj,jk) = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr 227 END DO 228 END DO 229 END DO 230 CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) ! save the trends 231 ! 232 ENDIF 233 234 ! Lateral boundary conditions on zti, zsi (unchanged sign) 235 CALL lbc_lnk( zti, 'T', 1. ) 236 CALL lbc_lnk( zsi, 'T', 1. ) 237 238 239 ! 3. antidiffusive flux : high order minus low order 240 ! -------------------------------------------------- 241 ! antidiffusive flux on i and j 242 DO jk = 1, jpkm1 243 DO jj = 1, jpjm1 244 DO ji = 1, fs_jpim1 ! vector opt. 245 zeu = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk) 246 zev = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk) 247 ztu(ji,jj,jk) = zeu * ( tn(ji,jj,jk) + tn(ji+1,jj,jk) ) - ztu(ji,jj,jk) 248 zsu(ji,jj,jk) = zeu * ( sn(ji,jj,jk) + sn(ji+1,jj,jk) ) - zsu(ji,jj,jk) 249 ztv(ji,jj,jk) = zev * ( tn(ji,jj,jk) + tn(ji,jj+1,jk) ) - ztv(ji,jj,jk) 250 zsv(ji,jj,jk) = zev * ( sn(ji,jj,jk) + sn(ji,jj+1,jk) ) - zsv(ji,jj,jk) 251 END DO 252 END DO 253 END DO 254 255 ! antidiffusive flux on k 256 ! Surface value 257 ztw(:,:,1) = 0.e0 258 zsw(:,:,1) = 0.e0 259 260 ! Interior value 261 DO jk = 2, jpkm1 262 DO jj = 1, jpj 263 DO ji = 1, jpi 264 zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk) 265 ztw(ji,jj,jk) = zew * ( tn(ji,jj,jk) + tn(ji,jj,jk-1) ) - ztw(ji,jj,jk) 266 zsw(ji,jj,jk) = zew * ( sn(ji,jj,jk) + sn(ji,jj,jk-1) ) - zsw(ji,jj,jk) 267 END DO 268 END DO 269 END DO 270 271 ! Lateral bondary conditions 272 CALL lbc_lnk( ztu, 'U', -1. ) ; CALL lbc_lnk( zsu, 'U', -1. ) 273 CALL lbc_lnk( ztv, 'V', -1. ) ; CALL lbc_lnk( zsv, 'V', -1. ) 274 CALL lbc_lnk( ztw, 'W', 1. ) ; CALL lbc_lnk( zsw, 'W', 1. ) 275 276 ! 4. monotonicity algorithm 277 ! ------------------------- 278 CALL nonosc( tb, ztu, ztv, ztw, zti, z2 ) 279 CALL nonosc( sb, zsu, zsv, zsw, zsi, z2 ) 280 281 282 ! 5. final trend with corrected fluxes 283 ! ------------------------------------ 284 DO jk = 1, jpkm1 285 DO jj = 2, jpjm1 286 DO ji = fs_2, fs_jpim1 ! vector opt. 287 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 288 ! total advective trends 289 ztat = - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk ) & 290 & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk ) & 291 & + ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) * zbtr 292 zsat = - ( zsu(ji,jj,jk) - zsu(ji-1,jj ,jk ) & 293 & + zsv(ji,jj,jk) - zsv(ji ,jj-1,jk ) & 294 & + zsw(ji,jj,jk) - zsw(ji ,jj ,jk+1) ) * zbtr 295 ! add them to the general tracer trends 296 ta(ji,jj,jk) = ta(ji,jj,jk) + ztat 297 sa(ji,jj,jk) = sa(ji,jj,jk) + zsat 298 END DO 299 END DO 300 END DO 301 302 303 ! Save the advective trends for diagnostics 304 ! -------------------------------------------- 305 306 IF( l_trdtra ) THEN 307 ztrdt(:,:,:) = 0.e0 ; ztrds(:,:,:) = 0.e0 308 ! 309 ! T/S ZONAL advection trends 310 DO jk = 1, jpkm1 311 DO jj = 2, jpjm1 312 DO ji = fs_2, fs_jpim1 ! vector opt. 313 !-- Compute zonal divergence by splitting hdivn (see divcur.F90) 314 ! N.B. This computation is not valid along OBCs (if any) 315 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 316 z_hdivn_x = ( e2u(ji ,jj) * fse3u(ji ,jj,jk) * pun(ji ,jj,jk) & 317 & - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr 318 !-- Compute T/S zonal advection trends 319 ztrdt(ji,jj,jk) = - ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_x 320 ztrds(ji,jj,jk) = - ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_x 321 END DO 322 END DO 323 END DO 324 CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt, cnbpas='bis') ! <<< ADD TO PREVIOUSLY COMPUTED 325 ! 326 ! T/S MERIDIONAL advection trends 327 DO jk = 1, jpkm1 328 DO jj = 2, jpjm1 329 DO ji = fs_2, fs_jpim1 ! vector opt. 330 !-- Compute merid. divergence by splitting hdivn (see divcur.F90) 331 ! N.B. This computation is not valid along OBCs (if any) 332 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 333 z_hdivn_y = ( e1v(ji, jj) * fse3v(ji,jj ,jk) * pvn(ji,jj ,jk) & 334 & - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr 335 !-- Compute T/S meridional advection trends 336 ztrdt(ji,jj,jk) = - ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_y 337 ztrds(ji,jj,jk) = - ( zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_y 338 END DO 339 END DO 340 END DO 341 CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt, cnbpas='bis') ! <<< ADD TO PREVIOUSLY COMPUTED 342 ! 343 ! T/S VERTICAL advection trends 344 DO jk = 1, jpkm1 345 DO jj = 2, jpjm1 346 DO ji = fs_2, fs_jpim1 ! vector opt. 347 zbtr1 = 1. / ( e1t(ji,jj) * e2t(ji,jj) ) 348 #if defined key_zco 349 zbtr = zbtr1 350 z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk) 351 z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk) 352 #else 353 zbtr = zbtr1 / fse3t(ji,jj,jk) 354 z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk) 355 z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk) 356 #endif 357 z_hdivn = (z_hdivn_x + z_hdivn_y) * zbtr 358 zbtr = zbtr1 / fse3t(ji,jj,jk) 359 ztrdt(ji,jj,jk) = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr - tn(ji,jj,jk) * z_hdivn 360 ztrds(ji,jj,jk) = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr - sn(ji,jj,jk) * z_hdivn 361 END DO 362 END DO 363 END DO 364 CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt, cnbpas='bis') ! <<< ADD TO PREVIOUSLY COMPUTED 365 ! 366 ENDIF 367 368 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' tvd adv - Ta: ', mask1=tmask, & 369 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 370 371 ! "zonal" mean advective heat and salt transport 372 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 373 pht_adv(:) = ptr_vj( ztv(:,:,:) ) + pht_adv(:) 374 pst_adv(:) = ptr_vj( zsv(:,:,:) ) + pst_adv(:) 375 ENDIF 247 ENDDO 248 ! 249 IF( l_trd ) THEN 250 DEALLOCATE( ztrdx ) ; DEALLOCATE( ztrdy ) ; DEALLOCATE( ztrdz ) 251 END IF 376 252 ! 377 253 END SUBROUTINE tra_adv_tvd … … 392 268 !!---------------------------------------------------------------------- 393 269 REAL(wp), INTENT( in ) :: prdt ! ??? 270 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT( in ) :: & 271 pbef, & ! before field 272 paft ! after field 394 273 REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT( inout ) :: & 395 pbef, & ! before field396 paft, & ! after field397 274 paa, & ! monotonic flux in the i direction 398 275 pbb, & ! monotonic flux in the j direction -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traadv_ubs.F90
r1528 r2024 4 4 !! Ocean active tracers: horizontal & vertical advective trend 5 5 !!============================================================================== 6 !! History : 9.0 ! 06-08 (L. Debreu, R. Benshila) Original code 6 !! History : 1.0 ! 2006-08 (L. Debreu, R. Benshila) Original code 7 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport 7 8 !!---------------------------------------------------------------------- 8 9 … … 13 14 USE oce ! ocean dynamics and active tracers 14 15 USE dom_oce ! ocean space and time domain 15 USE trdmod 16 USE trd mod_oce16 USE trdmod_oce ! ocean space and time domain 17 USE trdtra 17 18 USE lib_mpp 18 19 USE lbclnk ! ocean lateral boundary condition (or mpp link) … … 20 21 USE diaptr ! poleward transport diagnostics 21 22 USE dynspg_oce ! choice/control of key cpp for surface pressure gradient 22 USE prtctl23 23 24 24 IMPLICIT NONE … … 27 27 PUBLIC tra_adv_ubs ! routine called by traadv module 28 28 29 REAL(wp), DIMENSION(jpi,jpj) :: e1e2tr ! = 1/(e1t * e2t)29 LOGICAL :: l_trd ! flag to compute trends or not 30 30 31 31 !! * Substitutions … … 40 40 CONTAINS 41 41 42 SUBROUTINE tra_adv_ubs( kt, pun, pvn, pwn ) 42 SUBROUTINE tra_adv_ubs ( kt , cdtype, pun , pvn, pwn, & 43 & ptrab, ptran , ptraa, kjpt ) 43 44 !!---------------------------------------------------------------------- 44 45 !! *** ROUTINE tra_adv_ubs *** … … 67 68 !! the UBS have been found to be too diffusive. 68 69 !! 69 !! ** Action : - update ( ta,sa) with the now advective tracer trends70 !! ** Action : - update (ptraa) with the now advective tracer trends 70 71 !! 71 72 !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404. 72 73 !! Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741. 73 74 !!---------------------------------------------------------------------- 74 USE oce, ONLY : zwx => ua ! use ua as workspace 75 USE oce, ONLY : zwy => va ! use va as workspace 76 !! 77 INTEGER , INTENT(in) :: kt ! ocean time-step index 78 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pun ! effective ocean velocity, u_component 79 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvn ! effective ocean velocity, v_component 80 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pwn ! effective ocean velocity, w_component 81 !! 82 INTEGER :: ji, jj, jk ! dummy loop indices 83 REAL(wp) :: zta, zsa, zbtr, zcoef ! temporary scalars 84 REAL(wp) :: zfui, zfp_ui, zfm_ui, zcenut, zcenus ! " " 85 REAL(wp) :: zfvj, zfp_vj, zfm_vj, zcenvt, zcenvs ! " " 86 REAL(wp) :: z_hdivn_x, z_hdivn_y, z_hdivn ! " " 87 REAL(wp), DIMENSION(jpi,jpj) :: zeeu, zeev ! temporary 2D workspace 88 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz , zww ! temporary 3D workspace 89 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu , ztv , zltu , zltv, ztrdt ! " " 90 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsu , zsv , zlsu , zlsv, ztrds ! " " 91 !!---------------------------------------------------------------------- 92 93 zltu(:,:,:) = 0.e0 94 zltv(:,:,:) = 0.e0 95 zlsu(:,:,:) = 0.e0 96 zlsv(:,:,:) = 0.e0 75 !!* Module used 76 USE oce , zwx => ua ! use ua as workspace 77 USE oce , zwy => va ! use va as workspace 78 !!* Arguments 79 INTEGER , INTENT(in ) :: kt ! ocean time-step index 80 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 81 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk) :: pun, pvn, pwn ! 3 ocean velocity components 82 INTEGER , INTENT(in ) :: kjpt ! number of tracers 83 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab, ptran ! before and now tracer fields 84 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 85 !!* Local declarations 86 INTEGER :: ji, jj, jk, jn ! dummy loop indices 87 REAL(wp) :: ztra, zbtr, zcoef ! temporary scalars 88 REAL(wp) :: zfp_ui, zfm_ui, zcenut ! " " 89 REAL(wp) :: zfp_vj, zfm_vj, zcenvt ! " " ! " " 90 REAL(wp) :: z2dtt, z2 91 REAL(wp) :: ztak, zfp_wk, zfm_wk ! " " 92 REAL(wp) :: zeeu, zeev, z_hdivn 93 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zltu , zltv ! " " 94 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zti, ztw ! " " 95 !!---------------------------------------------------------------------- 96 97 97 98 98 IF( kt == nit000 ) THEN … … 101 101 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 102 102 ! 103 e1e2tr(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 103 l_trd = .FALSE. 104 IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) ) l_trd = .TRUE. 104 105 ENDIF 105 106 ! Save ta and sa trends107 ztrdt(:,:,:) = ta(:,:,:)108 ztrds(:,:,:) = sa(:,:,:)109 110 zcoef = 1./6.111 ! ! ===============112 DO jk = 1, jpkm1 ! Horizontal slab113 ! ! ===============114 115 ! Initialization of metric arrays (for z- or s-coordinates)116 DO jj = 1, jpjm1117 DO ji = 1, fs_jpim1 ! vector opt.118 #if defined key_zco119 ! z-coordinates, no vertical scale factors120 zeeu(ji,jj) = e2u(ji,jj) / e1u(ji,jj) * umask(ji,jj,jk)121 zeev(ji,jj) = e1v(ji,jj) / e2v(ji,jj) * vmask(ji,jj,jk)122 #else123 ! s-coordinates, vertical scale factor are used124 zeeu(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk)125 zeev(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk)126 #endif127 END DO128 END DO129 130 ! Laplacian131 ! First derivative (gradient)132 DO jj = 1, jpjm1133 DO ji = 1, fs_jpim1 ! vector opt.134 ztu(ji,jj,jk) = zeeu(ji,jj) * ( tb(ji+1,jj ,jk) - tb(ji,jj,jk) )135 zsu(ji,jj,jk) = zeeu(ji,jj) * ( sb(ji+1,jj ,jk) - sb(ji,jj,jk) )136 ztv(ji,jj,jk) = zeev(ji,jj) * ( tb(ji ,jj+1,jk) - tb(ji,jj,jk) )137 zsv(ji,jj,jk) = zeev(ji,jj) * ( sb(ji ,jj+1,jk) - sb(ji,jj,jk) )138 END DO139 END DO140 ! Second derivative (divergence)141 DO jj = 2, jpjm1142 DO ji = fs_2, fs_jpim1 ! vector opt.143 #if ! defined key_zco144 zcoef = 1. / ( 6. * fse3t(ji,jj,jk) )145 #endif146 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef147 zlsu(ji,jj,jk) = ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) ) * zcoef148 zltv(ji,jj,jk) = ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zcoef149 zlsv(ji,jj,jk) = ( zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) * zcoef150 END DO151 END DO152 ! ! =================153 END DO ! End of slab154 ! ! =================155 156 ! Lateral boundary conditions on the laplacian (zlt,zls) (unchanged sgn)157 CALL lbc_lnk( zltu, 'T', 1. ) ; CALL lbc_lnk( zlsu, 'T', 1. )158 CALL lbc_lnk( zltv, 'T', 1. ) ; CALL lbc_lnk( zlsv, 'T', 1. )159 160 ! ! ===============161 DO jk = 1, jpkm1 ! Horizontal slab162 ! ! ===============163 ! Horizontal advective fluxes164 DO jj = 1, jpjm1165 DO ji = 1, fs_jpim1 ! vector opt.166 ! volume fluxes * 1/2167 #if defined key_zco168 zfui = 0.5 * e2u(ji,jj) * pun(ji,jj,jk)169 zfvj = 0.5 * e1v(ji,jj) * pvn(ji,jj,jk)170 #else171 zfui = 0.5 * e2u(ji,jj) * fse3u(ji,jj,jk) * pun(ji,jj,jk)172 zfvj = 0.5 * e1v(ji,jj) * fse3v(ji,jj,jk) * pvn(ji,jj,jk)173 #endif174 ! upstream scheme175 zfp_ui = zfui + ABS( zfui )176 zfp_vj = zfvj + ABS( zfvj )177 zfm_ui = zfui - ABS( zfui )178 zfm_vj = zfvj - ABS( zfvj )179 ! centered scheme180 zcenut = zfui * ( tn(ji,jj,jk) + tn(ji+1,jj ,jk) )181 zcenvt = zfvj * ( tn(ji,jj,jk) + tn(ji ,jj+1,jk) )182 zcenus = zfui * ( sn(ji,jj,jk) + sn(ji+1,jj ,jk) )183 zcenvs = zfvj * ( sn(ji,jj,jk) + sn(ji ,jj+1,jk) )184 ! mixed centered / upstream scheme185 zwx(ji,jj,jk) = zcenut - zfp_ui * zltu(ji,jj,jk) -zfm_ui * zltu(ji+1,jj,jk)186 zwy(ji,jj,jk) = zcenvt - zfp_vj * zltv(ji,jj,jk) -zfm_vj * zltv(ji,jj+1,jk)187 zww(ji,jj,jk) = zcenus - zfp_ui * zlsu(ji,jj,jk) -zfm_ui * zlsu(ji+1,jj,jk)188 zwz(ji,jj,jk) = zcenvs - zfp_vj * zlsv(ji,jj,jk) -zfm_vj * zlsv(ji,jj+1,jk)189 END DO190 END DO191 192 ! Tracer flux divergence at t-point added to the general trend193 DO jj = 2, jpjm1194 DO ji = fs_2, fs_jpim1 ! vector opt.195 ! horizontal advective trends196 #if defined key_zco197 zbtr = e1e2tr(ji,jj)198 #else199 zbtr = e1e2tr(ji,jj) / fse3t(ji,jj,jk)200 #endif201 zta = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) &202 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) )203 zsa = - zbtr * ( zww(ji,jj,jk) - zww(ji-1,jj ,jk) &204 & + zwz(ji,jj,jk) - zwz(ji ,jj-1,jk) )205 ! add it to the general tracer trends206 ta(ji,jj,jk) = ta(ji,jj,jk) + zta207 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa208 END DO209 END DO210 ! ! ===============211 END DO ! End of slab212 ! ! ===============213 214 ! Horizontal trend used in tra_adv_ztvd subroutine215 zltu(:,:,:) = ta(:,:,:) - ztrdt(:,:,:)216 zlsu(:,:,:) = sa(:,:,:) - ztrds(:,:,:)217 218 ! 3. Save the horizontal advective trends for diagnostic219 ! ------------------------------------------------------220 IF( l_trdtra ) THEN221 ! Recompute the hoizontal advection zta & zsa trends computed222 ! at the step 2. above in making the difference between the new223 ! trends and the previous one ta()/sa - ztrdt()/ztrds() and add224 ! the term tn()/sn()*hdivn() to recover the Uh gradh(T/S) trends225 ztrdt(:,:,:) = 0.e0 ; ztrds(:,:,:) = 0.e0226 !227 ! T/S ZONAL advection trends228 DO jk = 1, jpkm1229 DO jj = 2, jpjm1230 DO ji = fs_2, fs_jpim1 ! vector opt.231 !-- Compute zonal divergence by splitting hdivn (see divcur.F90)232 #if defined key_zco233 zbtr = e1e2tr(ji,jj)234 z_hdivn_x = ( e2u(ji ,jj) * pun(ji ,jj,jk) &235 & - e2u(ji-1,jj) * pun(ji-1,jj,jk) ) * zbtr236 #else237 zbtr = e1e2tr(ji,jj) / fse3t(ji,jj,jk)238 z_hdivn_x = ( e2u(ji ,jj) * fse3u(ji ,jj,jk) * pun(ji ,jj,jk) &239 & - e2u(ji-1,jj) * fse3u(ji-1,jj,jk) * pun(ji-1,jj,jk) ) * zbtr240 #endif241 ztrdt(ji,jj,jk) = - ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_x242 ztrds(ji,jj,jk) = - ( zww(ji,jj,jk) - zww(ji-1,jj,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_x243 END DO244 END DO245 END DO246 CALL trd_mod(ztrdt, ztrds, jptra_trd_xad, 'TRA', kt) ! save the trends247 !248 ! T/S MERIDIONAL advection trends249 DO jk = 1, jpkm1250 DO jj = 2, jpjm1251 DO ji = fs_2, fs_jpim1 ! vector opt.252 !-- Compute merid. divergence by splitting hdivn (see divcur.F90)253 #if defined key_zco254 zbtr = e1e2tr(ji,jj)255 z_hdivn_y = ( e1v(ji, jj) * pvn(ji,jj ,jk) &256 & - e1v(ji,jj-1) * pvn(ji,jj-1,jk) ) * zbtr257 #else258 zbtr = e1e2tr(ji,jj) / fse3t(ji,jj,jk)259 z_hdivn_y = ( e1v(ji, jj) * fse3v(ji,jj ,jk) * pvn(ji,jj ,jk) &260 & - e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * pvn(ji,jj-1,jk) ) * zbtr261 #endif262 ztrdt(ji,jj,jk) = - ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) * zbtr + tn(ji,jj,jk) * z_hdivn_y263 ztrds(ji,jj,jk) = - ( zwz(ji,jj,jk) - zwz(ji,jj-1,jk) ) * zbtr + sn(ji,jj,jk) * z_hdivn_y264 END DO265 END DO266 END DO267 CALL trd_mod(ztrdt, ztrds, jptra_trd_yad, 'TRA', kt) ! save the trends268 !269 ENDIF270 271 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' ubs had - Ta: ', mask1=tmask, &272 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )273 274 ! "zonal" mean advective heat and salt transport275 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN276 IF( lk_zco ) THEN277 DO jk = 1, jpkm1278 DO jj = 2, jpjm1279 DO ji = fs_2, fs_jpim1 ! vector opt.280 zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk)281 zwz(ji,jj,jk) = zwz(ji,jj,jk) * fse3v(ji,jj,jk)282 END DO283 END DO284 END DO285 ENDIF286 pht_adv(:) = ptr_vj( zwy(:,:,:) )287 pst_adv(:) = ptr_vj( zwz(:,:,:) )288 ENDIF289 290 ! II. Vertical advection291 ! ----------------------292 IF( l_trdtra ) THEN ! Save ta and sa trends293 ztrdt(:,:,:) = ta(:,:,:)294 ztrds(:,:,:) = sa(:,:,:)295 ENDIF296 297 ! TVD scheme the vertical direction298 CALL tra_adv_ztvd(kt, pwn, zltu, zlsu)299 300 IF( l_trdtra ) THEN ! Save the final vertical advective trends301 DO jk = 1, jpkm1302 DO jj = 2, jpjm1303 DO ji = fs_2, fs_jpim1 ! vector opt.304 #if defined key_zco305 zbtr = e1e2tr(ji,jj)306 z_hdivn_x = e2u(ji,jj)*pun(ji,jj,jk) - e2u(ji-1,jj)*pun(ji-1,jj,jk)307 z_hdivn_y = e1v(ji,jj)*pvn(ji,jj,jk) - e1v(ji,jj-1)*pvn(ji,jj-1,jk)308 #else309 zbtr = e1e2tr(ji,jj) / fse3t(ji,jj,jk)310 z_hdivn_x = e2u(ji,jj)*fse3u(ji,jj,jk)*pun(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk)*pun(ji-1,jj,jk)311 z_hdivn_y = e1v(ji,jj)*fse3v(ji,jj,jk)*pvn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk)*pvn(ji,jj-1,jk)312 #endif313 z_hdivn = (z_hdivn_x + z_hdivn_y) * zbtr314 zbtr = e1e2tr(ji,jj) / fse3t(ji,jj,jk)315 ztrdt(ji,jj,jk) = ta(ji,jj,jk) - ztrdt(ji,jj,jk) - tn(ji,jj,jk) * z_hdivn316 ztrds(ji,jj,jk) = sa(ji,jj,jk) - ztrds(ji,jj,jk) - sn(ji,jj,jk) * z_hdivn317 END DO318 END DO319 END DO320 CALL trd_mod(ztrdt, ztrds, jptra_trd_zad, 'TRA', kt) ! <<< ADD TO PREVIOUSLY COMPUTED321 !322 ENDIF323 324 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' ubs zad - Ta: ', mask1=tmask, &325 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra')326 106 ! 327 END SUBROUTINE tra_adv_ubs328 329 330 SUBROUTINE tra_adv_ztvd( kt, pwn, zttrd, zstrd )331 !!----------------------------------------------------------------------332 !! *** ROUTINE tra_adv_ztvd ***333 !!334 !! ** Purpose : Compute the now trend due to total advection of335 !! tracers and add it to the general trend of tracer equations336 !!337 !! ** Method : TVD scheme, i.e. 2nd order centered scheme with338 !! corrected flux (monotonic correction)339 !! note: - this advection scheme needs a leap-frog time scheme340 !!341 !! ** Action : - update (ta,sa) with the now advective tracer trends342 !! - save the trends in (ztrdt,ztrds) ('key_trdtra')343 !!----------------------------------------------------------------------344 INTEGER , INTENT(in) :: kt ! ocean time-step345 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pwn ! verical effective velocity346 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: zttrd, zstrd ! lateral advective trends on T & S347 !!348 INTEGER :: ji, jj, jk ! dummy loop indices349 REAL(wp) :: z2dtt, zbtr, zew, z2 ! temporary scalar350 REAL(wp) :: ztak, zfp_wk ! " "351 REAL(wp) :: zsak, zfm_wk ! " "352 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zti, ztw ! temporary 3D workspace353 REAL(wp), DIMENSION (jpi,jpj,jpk) :: zsi, zsw ! " "354 !!----------------------------------------------------------------------355 356 IF( kt == nit000 .AND. lwp ) THEN357 WRITE(numout,*)358 WRITE(numout,*) 'tra_adv_ztvd : vertical TVD advection scheme'359 WRITE(numout,*) '~~~~~~~~~~~~'360 ENDIF361 362 107 IF( neuler == 0 .AND. kt == nit000 ) THEN ; z2 = 1. 363 108 ELSE ; z2 = 2. 364 109 ENDIF 365 366 ! Bottom value : flux set to zero367 ! --------------368 ztw(:,:,jpk) = 0.e0 ; zsw(:,:,jpk) = 0.e0369 zti (:,:,:) = 0.e0 ; zsi (:,:,:) = 0.e0370 371 372 ! upstream advection with initial mass fluxes & intermediate update373 ! -------------------------------------------------------------------374 ! Surface value375 IF( lk_vvl ) THEN376 ! variable volume : flux set to zero377 ztw(:,:,1) = 0.e0378 zsw(:,:,1) = 0.e0379 ELSE380 ! free surface-constant volume381 DO jj = 1, jpj382 DO ji = 1, jpi383 zew = e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,1)384 ztw(ji,jj,1) = zew * tb(ji,jj,1)385 zsw(ji,jj,1) = zew * sb(ji,jj,1)386 END DO387 END DO388 ENDIF389 390 ! Interior value391 DO jk = 2, jpkm1392 DO jj = 1, jpj393 DO ji = 1, jpi394 zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk)395 zfp_wk = zew + ABS( zew )396 zfm_wk = zew - ABS( zew )397 ztw(ji,jj,jk) = zfp_wk * tb(ji,jj,jk) + zfm_wk * tb(ji,jj,jk-1)398 zsw(ji,jj,jk) = zfp_wk * sb(ji,jj,jk) + zfm_wk * sb(ji,jj,jk-1)399 END DO400 END DO401 END DO402 403 ! update and guess with monotonic sheme404 DO jk = 1, jpkm1405 z2dtt = z2 * rdttra(jk)406 DO jj = 2, jpjm1407 DO ji = fs_2, fs_jpim1 ! vector opt.408 zbtr = 1./ ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )409 ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr410 zsak = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr411 ta(ji,jj,jk) = ta(ji,jj,jk) + ztak412 sa(ji,jj,jk) = sa(ji,jj,jk) + zsak413 zti (ji,jj,jk) = ( tb(ji,jj,jk) + z2dtt * ( ztak + zttrd(ji,jj,jk) ) ) * tmask(ji,jj,jk)414 zsi (ji,jj,jk) = ( sb(ji,jj,jk) + z2dtt * ( zsak + zstrd(ji,jj,jk) ) ) * tmask(ji,jj,jk)415 END DO416 END DO417 END DO418 419 ! Lateral boundary conditions on zti, zsi (unchanged sign)420 CALL lbc_lnk( zti, 'T', 1. )421 CALL lbc_lnk( zsi, 'T', 1. )422 423 424 ! antidiffusive flux : high order minus low order425 ! -------------------------------------------------426 ! Surface value427 ztw(:,:,1) = 0.e0 ; zsw(:,:,1) = 0.e0428 429 ! Interior value430 DO jk = 2, jpkm1431 DO jj = 1, jpj432 DO ji = 1, jpi433 zew = 0.5 * e1t(ji,jj) * e2t(ji,jj) * pwn(ji,jj,jk)434 ztw(ji,jj,jk) = zew * ( tn(ji,jj,jk) + tn(ji,jj,jk-1) ) - ztw(ji,jj,jk)435 zsw(ji,jj,jk) = zew * ( sn(ji,jj,jk) + sn(ji,jj,jk-1) ) - zsw(ji,jj,jk)436 END DO437 END DO438 END DO439 440 ! monotonicity algorithm441 ! ------------------------442 CALL nonosc_z( tb, ztw, zti, z2 )443 CALL nonosc_z( sb, zsw, zsi, z2 )444 445 446 ! final trend with corrected fluxes447 ! -----------------------------------448 DO jk = 1, jpkm1449 DO jj = 2, jpjm1450 DO ji = fs_2, fs_jpim1 ! vector opt.451 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )452 ! k- vertical advective trends453 ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr454 zsak = - ( zsw(ji,jj,jk) - zsw(ji,jj,jk+1) ) * zbtr455 ! add them to the general tracer trends456 ta(ji,jj,jk) = ta(ji,jj,jk) + ztak457 sa(ji,jj,jk) = sa(ji,jj,jk) + zsak458 END DO459 END DO460 END DO461 110 ! 462 END SUBROUTINE tra_adv_ztvd 463 111 ! ! =========== 112 DO jn = 1, kjpt ! tracer loop 113 ! ! =========== 114 ! 1. Bottom value : flux set to zero 115 ! ---------------------------------- 116 zltu(:,:,jpk) = 0.e0 ; zltv(:,:,jpk) = 0.e0 117 ! ! =============== 118 DO jk = 1, jpkm1 ! Horizontal slab 119 ! ! =============== 120 ! Laplacian 121 ! First derivative (gradient) 122 DO jj = 1, jpjm1 123 DO ji = 1, fs_jpim1 ! vector opt. 124 zeeu = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 125 zeev = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 126 ztu(ji,jj,jk) = zeeu * ( ptrab(ji+1,jj ,jk,jn) - ptrab(ji,jj,jk,jn) ) 127 ztv(ji,jj,jk) = zeev * ( ptrab(ji ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 128 END DO 129 END DO 130 ! Second derivative (divergence) 131 DO jj = 2, jpjm1 132 DO ji = fs_2, fs_jpim1 ! vector opt. 133 zcoef = 1. / ( 6. * fse3t(ji,jj,jk) ) 134 zltu(ji,jj,jk) = ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) ) * zcoef 135 zltv(ji,jj,jk) = ( ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) * zcoef 136 END DO 137 END DO 138 ! ! ================= 139 END DO ! End of slab 140 ! ! ================= 141 142 ! Lateral boundary conditions on the laplacian (zlt) (unchanged sgn) 143 CALL lbc_lnk( zltu, 'T', 1. ) ; CALL lbc_lnk( zltv, 'T', 1. ) 144 145 ! 146 ! Horizontal advective fluxes 147 DO jk = 1, jpkm1 148 DO jj = 1, jpjm1 149 DO ji = 1, fs_jpim1 ! vector opt. 150 ! upstream transport 151 zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 152 zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 153 zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 154 zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 155 ! centered scheme 156 zcenut = 0.5 * pun(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj ,jk,jn) ) 157 zcenvt = 0.5 * pvn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji ,jj+1,jk,jn) ) 158 ! UBS scheme 159 zwx(ji,jj,jk) = zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) 160 zwy(ji,jj,jk) = zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) 161 END DO 162 END DO 163 ENDDO 164 165 zltu(:,:,:) = ptraa(:,:,:,jn) ! store ptraa trends 166 167 ! Horizontal advective trends 168 DO jk = 1, jpkm1 169 ! Tracer flux divergence at t-point added to the general trend 170 DO jj = 2, jpjm1 171 DO ji = fs_2, fs_jpim1 ! vector opt. 172 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 173 ! horizontal advective 174 ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk) & 175 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk) ) 176 ! add it to the general tracer trends 177 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 178 END DO 179 END DO 180 ! ! =============== 181 END DO ! End of slab 182 ! ! =============== 183 184 ! Horizontal trend used in tra_adv_ztvd subroutine 185 zltu(:,:,:) = ptraa(:,:,:,jn) - zltu(:,:,:) 186 187 ! 3. Save the horizontal advective trends for diagnostic 188 ! ------------------------------------------------------ 189 ! ! trend diagnostics (contribution of upstream fluxes) 190 IF( l_trd ) THEN 191 CALL trd_tra( kt, cdtype, jn, jptra_trd_xad, zwx, pun, ptran(:,:,:,jn) ) 192 CALL trd_tra( kt, cdtype, jn, jptra_trd_yad, zwy, pvn, ptran(:,:,:,jn) ) 193 END IF 194 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 195 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 196 IF( lk_zco ) THEN 197 DO jk = 1, jpkm1 198 DO jj = 2, jpjm1 199 DO ji = fs_2, fs_jpim1 ! vector opt. 200 zwy(ji,jj,jk) = zwy(ji,jj,jk) * fse3v(ji,jj,jk) 201 END DO 202 END DO 203 END DO 204 ENDIF 205 IF( jn == jp_tem ) pht_adv(:) = ptr_vj( zwy(:,:,:) ) 206 IF( jn == jp_sal ) pst_adv(:) = ptr_vj( zwy(:,:,:) ) 207 ENDIF 208 209 ! TVD scheme for the vertical direction 210 ! ---------------------- 211 IF( l_trd ) zltv(:,:,:) = ptraa(:,:,:,jn) ! store pta if trend diag. 212 213 ! Bottom value : flux set to zero 214 ztw(:,:,jpk) = 0.e0 ; zti(:,:,jpk) = 0.e0 215 216 ! Surface value 217 IF( lk_vvl ) THEN ; ztw(:,:,1) = 0.e0 ! variable volume : flux set to zero 218 ELSE ; ztw(:,:,1) = pwn(:,:,1) * ptrab(:,:,1,jn) ! free constant surface 219 ENDIF 220 ! upstream advection with initial mass fluxes & intermediate update 221 ! ------------------------------------------------------------------- 222 ! Interior value 223 DO jk = 2, jpkm1 224 DO jj = 1, jpj 225 DO ji = 1, jpi 226 zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 227 zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 228 ztw(ji,jj,jk) = 0.5 * ( zfp_wk * ptrab(ji,jj,jk,jn) + zfm_wk * ptrab(ji,jj,jk-1,jn) ) 229 END DO 230 END DO 231 END DO 232 ! update and guess with monotonic sheme 233 DO jk = 1, jpkm1 234 z2dtt = z2 * rdttra(jk) 235 DO jj = 2, jpjm1 236 DO ji = fs_2, fs_jpim1 ! vector opt. 237 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 238 ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 239 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztak 240 zti(ji,jj,jk) = ( ptrab(ji,jj,jk,jn) + z2dtt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 241 END DO 242 END DO 243 END DO 244 ! 245 CALL lbc_lnk( zti, 'T', 1. ) ! Lateral boundary conditions on zti, zsi (unchanged sign) 246 247 ! antidiffusive flux : high order minus low order 248 ztw(:,:,1) = 0.e0 ! Surface value 249 DO jk = 2, jpkm1 ! Interior value 250 DO jj = 1, jpj 251 DO ji = 1, jpi 252 ztw(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptran(ji,jj,jk,jn) + ptran(ji,jj,jk-1,jn) ) - ztw(ji,jj,jk) 253 END DO 254 END DO 255 END DO 256 ! 257 CALL nonosc_z( ptrab(:,:,:,jn), ztw, zti, z2 ) ! monotonicity algorithm 258 259 ! final trend with corrected fluxes 260 DO jk = 1, jpkm1 261 DO jj = 2, jpjm1 262 DO ji = fs_2, fs_jpim1 ! vector opt. 263 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 264 ! k- vertical advective trends 265 ztra = - zbtr * ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) 266 ! added to the general tracer trends 267 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 268 END DO 269 END DO 270 END DO 271 272 ! Save the final vertical advective trends 273 IF( l_trd ) THEN ! vertical advective trend diagnostics 274 DO jk = 1, jpkm1 ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 275 DO jj = 2, jpjm1 276 DO ji = fs_2, fs_jpim1 ! vector opt. 277 zbtr = 1.e0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 278 z_hdivn = ( pwn(ji,jj,jk) - pwn(ji,jj,jk+1) ) * zbtr 279 zltv(ji,jj,jk) = ptraa(ji,jj,jk,jn) - zltv(ji,jj,jk) + ptran(ji,jj,jk,jn) * z_hdivn 280 END DO 281 END DO 282 END DO 283 CALL trd_tra( kt, cdtype, jn, jptra_trd_zad, zltv ) 284 ENDIF 285 ! 286 ENDDO 287 ! 288 END SUBROUTINE tra_adv_ubs 464 289 465 290 SUBROUTINE nonosc_z( pbef, pcc, paft, prdt ) … … 477 302 !!---------------------------------------------------------------------- 478 303 REAL(wp), INTENT(in ) :: prdt ! ??? 479 REAL(wp), INTENT(inout),DIMENSION (jpi,jpj,jpk) :: pbef ! before field304 REAL(wp), DIMENSION (jpi,jpj,jpk) :: pbef ! before field 480 305 REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) :: paft ! after field 481 306 REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) :: pcc ! monotonic flux in the k direction … … 525 350 pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) 526 351 paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) 527 352 528 353 529 354 ! 2. Positive and negative part of fluxes and beta terms … … 544 369 END DO 545 370 END DO 546 547 371 ! monotonic flux in the k direction, i.e. pcc 548 372 ! ------------------------------------------- -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trabbc.F90
r1601 r2024 18 18 USE dom_oce ! ocean space and time domain 19 19 USE phycst ! physical constants 20 USE trdmod 21 USE trd mod_oce ! ocean variables trends20 USE trdmod_oce ! ocean trends 21 USE trdtra ! ocean trends 22 22 USE in_out_manager ! I/O manager 23 23 USE prtctl ! Print control … … 27 27 28 28 PUBLIC tra_bbc ! routine called by step.F90 29 PUBLIC tra_bbc_init ! routine called by opa.F90 29 30 30 31 !! to be transfert in the namelist ???! … … 70 71 !! Emile-Geay and Madec, 2009, Ocean Science. 71 72 !!---------------------------------------------------------------------- 72 USE oce, ONLY : ztrdt => ua ! use ua as 3D workspace73 USE oce, ONLY : ztrds => va ! use va as 3D workspace74 73 !! 75 74 INTEGER, INTENT( in ) :: kt ! ocean time-step index 76 75 !! 77 INTEGER :: ji, jj ! dummy loop indices76 INTEGER :: ji, jj, ik ! dummy loop indices 78 77 REAL(wp) :: zqgh_trd ! geothermal heat flux trend 78 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 79 79 !!---------------------------------------------------------------------- 80 80 81 IF( kt == nit000 ) CALL tra_bbc_init ! Initialization82 83 81 IF( l_trdtra ) THEN ! Save ta and sa trends 84 ztrdt(:,:,:) = ta(:,:,:)85 ztrds(:,:,:) = 0.e082 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 83 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = 0. 86 84 ENDIF 87 85 … … 98 96 DO ji = 2, jpim1 99 97 #endif 100 zqgh_trd = ro0cpr * qgh_trd0(ji,jj) / fse3t(ji,jj,nbotlevt(ji,jj)) 101 ta(ji,jj,nbotlevt(ji,jj)) = ta(ji,jj,nbotlevt(ji,jj)) + zqgh_trd 98 ik = nbotlevt(ji,jj) 99 zqgh_trd = ro0cpr * qgh_trd0(ji,jj) / fse3t(ji,jj,ik) 100 tsa(ji,jj,ik,jp_tem) = tsa(ji,jj,ik,jp_tem) + zqgh_trd 102 101 END DO 103 102 END DO … … 105 104 106 105 IF( l_trdtra ) THEN ! Save the geothermal heat flux trend for diagnostics 107 ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 108 CALL trd_mod( ztrdt, ztrds, jptra_trd_bbc, 'TRA', kt ) 106 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 107 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_bbc, ztrdt ) 108 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_bbc, ztrds ) 109 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 109 110 ENDIF 110 111 ! 111 IF(ln_ctl) CALL prt_ctl( tab3d_1=t a, clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' )112 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbc - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 112 113 ! 113 114 END SUBROUTINE tra_bbc -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trabbl.F90
r1601 r2024 4 4 !! Ocean physics : advective and/or diffusive bottom boundary layer scheme 5 5 !!============================================================================== 6 !! History : 8.0 ! 96-06 (L. Mortier) Original code 7 !! 8.0 ! 97-11 (G. Madec) Optimization 8 !! 8.5 ! 02-08 (G. Madec) free form + modules 9 !!---------------------------------------------------------------------- 10 #if defined key_trabbl_dif || defined key_trabbl_adv || defined key_esopa 11 !!---------------------------------------------------------------------- 12 !! 'key_trabbl_dif' or diffusive bottom boundary layer 13 !! 'key_trabbl_adv' advective bottom boundary layer 14 !!---------------------------------------------------------------------- 15 !!---------------------------------------------------------------------- 16 !! tra_bbl_dif : update the active tracer trends due to the bottom 17 !! boundary layer (diffusive only) 18 !! tra_bbl_adv : update the active tracer trends due to the bottom 19 !! boundary layer (advective and/or diffusive) 20 !! tra_bbl_init : initialization, namlist read, parameters control 21 !!---------------------------------------------------------------------- 22 USE oce ! ocean dynamics and active tracers 23 USE dom_oce ! ocean space and time domain 24 USE trdmod ! ocean active tracers trends 25 USE trdmod_oce ! ocean variables trends 26 USE in_out_manager ! I/O manager 27 USE lbclnk ! ocean lateral boundary conditions 28 USE prtctl ! Print control 6 !! History : OPA ! 1996-06 (L. Mortier) Original code 7 !! 8.0 ! 1997-11 (G. Madec) Optimization 8 !! NEMO 1.0 ! 2002-08 (G. Madec) free form + modules 9 !! - ! 2004-01 (A. de Miranda, G. Madec, J.M. Molines ) add advective bbl 10 !! 3.3 ! 2009-11 (G. Madec) merge trabbl and trabbl_adv + style + optimization 11 !! - ! 2010-04 (G. Madec) Campin & Goosse advective bbl 12 !! - ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC 13 !!---------------------------------------------------------------------- 14 #if defined key_trabbl || defined key_esopa 15 !!---------------------------------------------------------------------- 16 !! 'key_trabbl' or bottom boundary layer 17 !!---------------------------------------------------------------------- 18 !! tra_bbl : update the tracer trends due to the bottom boundary layer (advective and/or diffusive) 19 !! tra_bbl_dif : generic routine to compute bbl diffusive trend 20 !! tra_bbl_adv : generic routine to compute bbl advective trend 21 !! bbl : computation of bbl diffu. flux coef. & transport in bottom boundary layer 22 !! tra_bbl_init : initialization, namlist read, parameters control 23 !!---------------------------------------------------------------------- 24 USE oce ! ocean dynamics and active tracers 25 USE dom_oce ! ocean space and time domain 26 USE phycst ! 27 USE eosbn2 ! equation of state 28 USE trdmod_oce ! ocean space and time domain 29 USE trdtra ! ocean active tracers trends 30 USE iom ! IOM server 31 USE in_out_manager ! I/O manager 32 USE lbclnk ! ocean lateral boundary conditions 33 USE prtctl ! Print control 29 34 30 35 IMPLICIT NONE 31 36 PRIVATE 32 37 33 PUBLIC tra_bbl_dif !routine called by step.F9034 PUBLIC tra_bbl_adv ! routine called by step.F9035 36 !!* Namelist nambbl: bottom boundary layer37 REAL(wp), PUBLIC :: rn_ahtbbl = 1.e+3 !: lateral coeff. for bottom boundary layer scheme (m2/s)38 39 # if defined key_trabbl _dif40 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl _dif = .TRUE. !: diffusivebottom boundary layer flag38 PUBLIC tra_bbl ! routine called by step.F90 39 PUBLIC tra_bbl_init ! routine called by opa.F90 40 PUBLIC tra_bbl_dif ! routine called by tra_bbl and trc_bbl 41 PUBLIC tra_bbl_adv ! - - - - 42 PUBLIC bbl ! - - - - 43 44 # if defined key_trabbl 45 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl = .TRUE. !: bottom boundary layer flag 41 46 # else 42 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl _dif = .FALSE. !: diffusivebottom boundary layer flag47 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl = .FALSE. !: bottom boundary layer flag 43 48 # endif 44 49 45 # if defined key_trabbl_adv 46 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl_adv = .TRUE. !: advective bottom boundary layer flag 47 REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jpk) :: u_bbl !: 3 components of the velocity 48 REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jpk) :: v_bbl !: associated with advective BBL 49 REAL(wp), PUBLIC, DIMENSION(jpi,jpj,jpk) :: w_bbl !: (only affect tracer) 50 # else 51 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl_adv = .FALSE. !: advective bottom boundary layer flag 52 # endif 53 54 INTEGER, DIMENSION(jpi,jpj) :: mbkt ! vertical index of the bottom ocean T-level 55 INTEGER, DIMENSION(jpi,jpj) :: mbku, mbkv ! vertical index of the bottom ocean U/V-level 50 ! !!* Namelist nambbl * 51 INTEGER , PUBLIC :: nn_bbl_ldf = 0 !: =1 : diffusive bbl or not (=0) 52 INTEGER , PUBLIC :: nn_bbl_adv = 0 !: =1/2 : advective bbl or not (=0) 53 ! ! =1 : advective bbl using the model velocity 54 ! ! =2 : - - using utr_bbl proportional to grad(rho) 55 REAL(wp), PUBLIC :: rn_ahtbbl = 1.e+3 !: along slope bbl diffusive coefficient [m2/s] 56 REAL(wp), PUBLIC :: rn_gambbl = 10.e0 !: lateral coeff. for bottom boundary layer scheme [s] 57 58 INTEGER , DIMENSION(jpi,jpj) :: mbkt ! vertical index of the bottom ocean T-level 59 INTEGER , DIMENSION(jpi,jpj) :: mbku , mbkv ! vertical index of the (upper) bottom ocean U/V-level 60 INTEGER , DIMENSION(jpi,jpj) :: mbku_d , mbkv_d ! vertical index of the "lower" bottom ocean U/V-level 61 INTEGER , DIMENSION(jpi,jpj) :: mgrhu , mgrhv ! = +/-1, sign of grad(H) in u-(v-)direction 62 REAL(wp), DIMENSION(jpi,jpj), PUBLIC :: utr_bbl , vtr_bbl ! u- (v-) transport in the bottom boundary layer 63 REAL(wp), DIMENSION(jpi,jpj) :: ahu_bbl_0, ahv_bbl_0 ! diffusive bbl flux coefficients at u and v-points 64 REAL(wp), DIMENSION(jpi,jpj) :: ahu_bbl , ahv_bbl ! masked diffusive bbl coefficients at u and v-points 65 REAL(wp), DIMENSION(jpi,jpj) :: e3u_bbl_0, e3v_bbl_0 ! thichness of the bbl (e3) at u and v-points 66 REAL(wp), DIMENSION(jpi,jpj) :: e1e2t_r ! thichness of the bbl (e3) at u and v-points 67 LOGICAL, PUBLIC :: l_bbl !: flag to compute bbl diffu. flux coef and transport 56 68 57 69 !! * Substitutions … … 59 71 # include "vectopt_loop_substitute.h90" 60 72 !!---------------------------------------------------------------------- 61 !! OPA 9.0 , LOCEAN-IPSL (2006)73 !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009) 62 74 !! $Id$ 63 75 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) … … 66 78 CONTAINS 67 79 68 SUBROUTINE tra_bbl_dif( kt ) 69 !!---------------------------------------------------------------------- 70 !! *** ROUTINE tra_bbl_dif *** 71 !! 80 81 SUBROUTINE tra_bbl( kt ) 82 !!---------------------------------------------------------------------- 83 !! *** ROUTINE bbl *** 84 !! 72 85 !! ** Purpose : Compute the before tracer (t & s) trend associated 73 !! with the bottom boundary layer and add it to the general trend 74 !! of tracer equations. The bottom boundary layer is supposed to be 75 !! a purely diffusive bottom boundary layer. 76 !! 77 !! ** Method : When the product grad( rho) * grad(h) < 0 (where grad 78 !! is an along bottom slope gradient) an additional lateral diffu- 79 !! sive trend along the bottom slope is added to the general tracer 80 !! trend, otherwise nothing is done. 81 !! Second order operator (laplacian type) with variable coefficient 82 !! computed as follow for temperature (idem on s): 83 !! difft = 1/(e1t*e2t*e3t) { di-1[ ahbt e2u*e3u/e1u di[ztb] ] 84 !! + dj-1[ ahbt e1v*e3v/e2v dj[ztb] ] } 85 !! where ztb is a 2D array: the bottom ocean temperature and ahtb 86 !! is a time and space varying diffusive coefficient defined by: 87 !! ahbt = zahbp if grad(rho).grad(h) < 0 88 !! = 0. otherwise. 89 !! Note that grad(.) is the along bottom slope gradient. grad(rho) 90 !! is evaluated using the local density (i.e. referenced at the 91 !! local depth). Typical value of ahbt is 2000 m2/s (equivalent to 86 !! with the bottom boundary layer and add it to the general trend 87 !! of tracer equations. 88 !! 89 !!---------------------------------------------------------------------- 90 INTEGER, INTENT( in ) :: kt ! ocean time-step 91 ! 92 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 93 !!---------------------------------------------------------------------- 94 95 IF( l_trdtra ) THEN !* Save ta and sa trends 96 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 97 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsa(:,:,:,jp_sal) 98 ENDIF 99 100 !* bbl coef and transport are computed only if not already done in passive tracers routine 101 IF( l_bbl ) CALL bbl( kt, 'TRA' ) 102 103 !* Diffusive bbl : 104 IF( nn_bbl_ldf == 1 ) THEN 105 CALL tra_bbl_dif( tsb, tsa, jpts ) 106 IF( ln_ctl ) & 107 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & 108 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 109 ! lateral boundary conditions ; just need for outputs 110 CALL lbc_lnk( ahu_bbl, 'U', 1. ) ; CALL lbc_lnk( ahv_bbl, 'V', 1. ) 111 CALL iom_put( "ahu_bbl", ahu_bbl ) ! bbl diffusive flux i-coef 112 CALL iom_put( "ahv_bbl", ahv_bbl ) ! bbl diffusive flux j-coef 113 END IF 114 115 !* Advective bbl : bbl upstream advective trends added to the tracer trends 116 IF( nn_bbl_adv /= 0 ) THEN 117 CALL tra_bbl_adv( tsb, tsa, jpts ) 118 IF(ln_ctl) & 119 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & 120 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 121 ! lateral boundary conditions ; just need for outputs 122 CALL lbc_lnk( utr_bbl, 'U', 1. ) ; CALL lbc_lnk( vtr_bbl, 'V', 1. ) 123 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 124 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport 125 END IF 126 127 IF( l_trdtra ) THEN ! save the horizontal diffusive trends for further diagnostics 128 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 129 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 130 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_bbl, ztrdt ) 131 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_bbl, ztrds ) 132 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 133 ENDIF 134 ! 135 END SUBROUTINE tra_bbl 136 137 138 SUBROUTINE tra_bbl_dif( ptrab, ptraa, kjpt ) 139 !!---------------------------------------------------------------------- 140 !! *** ROUTINE tra_bbl_dif *** 141 !! 142 !! ** Purpose : Computes the bottom boundary horizontal and vertical 143 !! advection terms. 144 !! 145 !! ** Method : 146 !! * diffusive bbl (nn_bbl_ldf=1) : 147 !! When the product grad( rho) * grad(h) < 0 (where grad is an 148 !! along bottom slope gradient) an additional lateral 2nd order 149 !! diffusion along the bottom slope is added to the general 150 !! tracer trend, otherwise the additional trend is set to 0. 151 !! A typical value of ahbt is 2000 m2/s (equivalent to 92 152 !! a downslope velocity of 20 cm/s if the condition for slope 93 153 !! convection is satified) 94 !! Add this before trend to the general trend (ta,sa) of the 95 !! botton ocean tracer point: 96 !! ta = ta + difft 97 !! 98 !! ** Action : - update (ta,sa) at the bottom level with the bottom 99 !! boundary layer trend 100 !! - save the trends in ztrdt/ztrds ('key_trdtra') 154 !! 101 155 !! 102 156 !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 103 !!---------------------------------------------------------------------- 104 USE oce, ONLY : ztrdt => ua ! use ua as 3D workspace 105 USE oce, ONLY : ztrds => va ! use va as 3D workspace 106 USE eosbn2 ! equation of state 107 !! 108 INTEGER, INTENT( in ) :: kt ! ocean time-step 109 !! 110 INTEGER :: ji, jj ! dummy loop indices 111 INTEGER :: ik 112 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers 113 INTEGER :: iku1, iku2, ikv1,ikv2 ! temporary intergers 114 REAL(wp) :: ze3u, ze3v ! temporary scalars 115 INTEGER :: iku, ikv 116 REAL(wp) :: zsign, zt, zs, zh, zalbet ! temporary scalars 117 REAL(wp) :: zgdrho, zbtr, zta, zsa 118 REAL(wp), DIMENSION(jpi,jpj) :: zki, zkj, zkw, zkx, zky, zkz ! 2D workspace 119 REAL(wp), DIMENSION(jpi,jpj) :: ztnb, zsnb, zdep, ztbb, zsbb, zahu, zahv 120 !! 121 REAL(wp) :: fsalbt, pft, pfs, pfh ! statement function 122 !!---------------------------------------------------------------------- 123 ! ratio alpha/beta 124 ! ================ 125 ! fsalbt: ratio of thermal over saline expension coefficients 126 ! pft : potential temperature in degrees celcius 127 ! pfs : salinity anomaly (s-35) in psu 128 ! pfh : depth in meters 129 130 fsalbt( pft, pfs, pfh ) = & 131 ( ( ( -0.255019e-07 * pft + 0.298357e-05 ) * pft & 132 & - 0.203814e-03 ) * pft & 133 & + 0.170907e-01 ) * pft & 134 & + 0.665157e-01 & 135 +(-0.678662e-05 * pfs - 0.846960e-04 * pft + 0.378110e-02 ) * pfs & 136 + ( ( - 0.302285e-13 * pfh & 137 & - 0.251520e-11 * pfs & 138 & + 0.512857e-12 * pft * pft ) * pfh & 139 & - 0.164759e-06 * pfs & 140 & +( 0.791325e-08 * pft - 0.933746e-06 ) * pft & 141 & + 0.380374e-04 ) * pfh 142 !!---------------------------------------------------------------------- 143 144 IF( kt == nit000 ) CALL tra_bbl_init 145 146 IF( l_trdtra ) THEN ! Save ta and sa trends 147 ztrdt(:,:,:) = ta(:,:,:) 148 ztrds(:,:,:) = sa(:,:,:) 149 ENDIF 150 151 ! 0. 2D fields of bottom temperature and salinity, and bottom slope 152 ! ----------------------------------------------------------------- 153 ! mbathy= number of w-level, minimum value=1 (cf dommsk.F) 157 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 158 !!---------------------------------------------------------------------- 159 !!* Arguments 160 INTEGER , INTENT(in ) :: kjpt ! number of tracers 161 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 162 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 163 ! 164 INTEGER :: ji, jj, jn ! dummy loop indices 165 INTEGER :: ik ! temporary integers 166 REAL(wp) :: zbtr, ztra ! temporary 167 REAL(wp), DIMENSION(jpi,jpj) :: ztrb, zkx, zky ! 2D workspace 168 !!---------------------------------------------------------------------- 169 ! =========== 170 DO jn = 1, kjpt ! tracer loop 171 ! ! =========== 172 #if defined key_vectopt_loop 173 DO jj = 1, 1 ! vector opt. (forced unrolling) 174 DO ji = 1, jpij 175 #else 176 DO jj = 1, jpj 177 DO ji = 1, jpi 178 #endif 179 ik = mbkt(ji,jj) ! bottom T-level index 180 ztrb(ji,jj) = ptrab(ji,jj,ik,jn) ! bottom before T and S 181 END DO 182 END DO 183 ! 154 184 # if defined key_vectopt_loop 155 DO jj = 1, 1 156 DO ji = 1, jpij ! vector opt. (forced unrolling) 157 # else 158 DO jj = 1, jpj 159 DO ji = 1, jpi 160 # endif 161 ik = mbkt(ji,jj) ! index of the bottom ocean T-level 162 ztnb(ji,jj) = tn(ji,jj,ik) * tmask(ji,jj,1) ! masked now T and S at ocean bottom 163 zsnb(ji,jj) = sn(ji,jj,ik) * tmask(ji,jj,1) 164 ztbb(ji,jj) = tb(ji,jj,ik) * tmask(ji,jj,1) ! masked before T and S at ocean bottom 165 zsbb(ji,jj) = sb(ji,jj,ik) * tmask(ji,jj,1) 166 zdep(ji,jj) = fsdept(ji,jj,ik) ! depth of the ocean bottom T-level 167 END DO 168 END DO 169 170 IF( ln_zps ) THEN ! partial steps correction 171 # if defined key_vectopt_loop 172 DO jj = 1, 1 173 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 174 # else 175 DO jj = 1, jpjm1 176 DO ji = 1, jpim1 177 # endif 178 iku1 = MAX( mbathy(ji+1,jj )-1, 1 ) 179 iku2 = MAX( mbathy(ji ,jj )-1, 1 ) 180 ikv1 = MAX( mbathy(ji ,jj+1)-1, 1 ) 181 ikv2 = MAX( mbathy(ji ,jj )-1, 1 ) 182 ze3u = MIN( fse3u(ji,jj,iku1), fse3u(ji,jj,iku2) ) 183 ze3v = MIN( fse3v(ji,jj,ikv1), fse3v(ji,jj,ikv2) ) 184 zahu(ji,jj) = rn_ahtbbl * e2u(ji,jj) * ze3u / e1u(ji,jj) * umask(ji,jj,1) 185 zahv(ji,jj) = rn_ahtbbl * e1v(ji,jj) * ze3v / e2v(ji,jj) * vmask(ji,jj,1) 186 END DO 187 END DO 188 ELSE ! z-coordinate - full steps or s-coordinate 189 # if defined key_vectopt_loop 190 DO jj = 1, 1 191 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 192 # else 193 DO jj = 1, jpjm1 194 DO ji = 1, jpim1 195 # endif 196 iku = mbku(ji,jj) 197 ikv = mbkv(ji,jj) 198 zahu(ji,jj) = rn_ahtbbl * e2u(ji,jj) * fse3u(ji,jj,iku) / e1u(ji,jj) * umask(ji,jj,1) 199 zahv(ji,jj) = rn_ahtbbl * e1v(ji,jj) * fse3v(ji,jj,ikv) / e2v(ji,jj) * vmask(ji,jj,1) 200 END DO 201 END DO 202 ENDIF 203 204 ! 1. Criteria of additional bottom diffusivity: grad(rho).grad(h)<0 205 ! -------------------------------------------- 206 ! Sign of the local density gradient along the i- and j-slopes 207 ! multiplied by the slope of the ocean bottom 208 209 SELECT CASE ( nn_eos ) 210 ! 211 CASE ( 0 ) !== Jackett and McDougall (1994) formulation ==! 212 # if defined key_vectopt_loop 213 DO jj = 1, 1 214 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 185 DO jj = 1, 1 ! vector opt. (forced unrolling) 186 DO ji = 1, jpij-jpi 215 187 # else 216 188 DO jj = 1, jpjm1 217 189 DO ji = 1, jpim1 218 190 # endif 219 ! temperature, salinity anomalie and depth 220 zt = 0.5 * ( ztnb(ji,jj) + ztnb(ji+1,jj) ) 221 zs = 0.5 * ( zsnb(ji,jj) + zsnb(ji+1,jj) ) - 35.0 222 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 223 ! masked ratio alpha/beta 224 zalbet = fsalbt( zt, zs, zh )*umask(ji,jj,1) 225 ! local density gradient along i-bathymetric slope 226 zgdrho = zalbet * ( ztnb(ji+1,jj) - ztnb(ji,jj) ) & 227 - ( zsnb(ji+1,jj) - zsnb(ji,jj) ) 228 ! sign of local i-gradient of density multiplied by the i-slope 229 zsign = SIGN( 0.5, - zgdrho * ( zdep(ji+1,jj) - zdep(ji,jj) ) ) 230 zki(ji,jj) = ( 0.5 - zsign ) * zahu(ji,jj) 231 ! 232 ! temperature, salinity anomalie and depth 233 zt = 0.5 * ( ztnb(ji,jj+1) + ztnb(ji,jj) ) 234 zs = 0.5 * ( zsnb(ji,jj+1) + zsnb(ji,jj) ) - 35.0 235 zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 236 ! masked ratio alpha/beta 237 zalbet = fsalbt( zt, zs, zh )*vmask(ji,jj,1) 238 ! local density gradient along j-bathymetric slope 239 zgdrho = zalbet * ( ztnb(ji,jj+1) - ztnb(ji,jj) ) & 240 - ( zsnb(ji,jj+1) - zsnb(ji,jj) ) 241 ! sign of local j-gradient of density multiplied by the j-slope 242 zsign = sign( 0.5, -zgdrho * ( zdep(ji,jj+1) - zdep(ji,jj) ) ) 243 zkj(ji,jj) = ( 0.5 - zsign ) * zahv(ji,jj) 191 zkx(ji,jj) = ahu_bbl(ji,jj) * ( ztrb(ji+1,jj ) - ztrb(ji,jj) ) ! diffusive i-flux 192 zky(ji,jj) = ahv_bbl(ji,jj) * ( ztrb(ji ,jj+1) - ztrb(ji,jj) ) ! diffusive j-flux 244 193 END DO 245 194 END DO 246 ! 247 CASE ( 1 ) !== Linear formulation function of temperature only ==! 195 ! ! Add the diffusive trends 248 196 # if defined key_vectopt_loop 197 DO jj = 1, 1 ! vector opt. (forced unrolling) 198 DO ji = jpi+1, jpij-jpi-1 199 # else 200 DO jj = 2, jpjm1 201 DO ji = 2, jpim1 202 # endif 203 ik = mbkt(ji,jj) 204 zbtr = e1e2t_r(ji,jj) / fse3t(ji,jj,ik) 205 ztra = ( zkx(ji,jj) - zkx(ji-1,jj) + zky(ji,jj) - zky(ji,jj-1) ) * zbtr 206 ptraa(ji,jj,ik,jn) = ptraa(ji,jj,ik,jn) + ztra 207 END DO 208 END DO 209 ! 210 END DO 211 ! 212 END SUBROUTINE tra_bbl_dif 213 214 SUBROUTINE tra_bbl_adv( ptrab, ptraa, kjpt ) 215 !!---------------------------------------------------------------------- 216 !! *** ROUTINE trc_bbl *** 217 !! 218 !! ** Purpose : Compute the before passive tracer trend associated 219 !! with the bottom boundary layer and add it to the general trend 220 !! of tracer equations. 221 !! * advective bbl (nn_bbl_adv=1 or 2) : 222 !! nn_bbl_adv = 1 use of the ocean velocity as bbl velocity 223 !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation 224 !! i.e. transport proportional to the along-slope density gradient 225 !! 226 !! NB: the along slope density gradient is evaluated using the 227 !! local density (i.e. referenced at a common local depth). 228 !! 229 !! 230 !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 231 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 232 !! 233 !!---------------------------------------------------------------------- 234 !!* Arguments 235 INTEGER , INTENT(in ) :: kjpt ! number of tracers 236 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 237 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 238 ! 239 INTEGER :: ji, jj, jk, jn ! dummy loop indices 240 INTEGER :: ik ! temporary integers 241 INTEGER :: iis , iid , ijs , ijd ! - - 242 INTEGER :: ikus, ikud, ikvs, ikvd ! - - 243 REAL(wp) :: zbtr, ztra ! - - 244 REAL(wp) :: zu_bbl, zv_bbl ! - - 245 !!---------------------------------------------------------------------- 246 247 ! ! =========== 248 DO jn = 1, kjpt ! tracer loop 249 ! ! =========== 250 # if defined key_vectopt_loop 249 251 DO jj = 1, 1 250 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 252 DO ji = jpi+1, jpij-jpi-1 ! vector opt. (forced unrolling) 253 # else 254 DO jj = 2, jpjm1 255 DO ji = 1, jpim1 ! CAUTION start from i=1 to update i=2 when cyclic east-west 256 # endif 257 IF( utr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero i-direction bbl advection 258 ! down-slope i/k-indices (deep) & up-slope i/k indices (shelf) 259 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 260 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 261 zu_bbl = ABS( utr_bbl(ji,jj) ) 262 ! 263 ! ! up -slope T-point (shelf bottom point) 264 zbtr = e1e2t_r(iis,jj) / fse3t(iis,jj,ikus) 265 ztra = zu_bbl * ( ptrab(iid,jj,ikus,jn) - ptrab(iis,jj,ikus,jn) ) * zbtr 266 ptraa(iis,jj,ikus,jn) = ptraa(iis,jj,ikus,jn) + ztra 267 ! 268 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 269 zbtr = e1e2t_r(iid,jj) / fse3t(iid,jj,jk) 270 ztra = zu_bbl * ( ptrab(iid,jj,jk+1,jn) - ptrab(iid,jj,jk,jn) ) * zbtr 271 ptraa(iid,jj,jk,jn) = ptraa(iid,jj,jk,jn) + ztra 272 END DO 273 ! 274 zbtr = e1e2t_r(iid,jj) / fse3t(iid,jj,ikud) 275 ztra = zu_bbl * ( ptrab(iis,jj,ikus,jn) - ptrab(iid,jj,ikud,jn) ) * zbtr 276 ptraa(iid,jj,ikud,jn) = ptraa(iid,jj,ikud,jn) + ztra 277 ENDIF 278 IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN ! non-zero j-direction bbl advection 279 ! down-slope j/k-indices (deep) & up-slope j/k indices (shelf) 280 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 281 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 282 zv_bbl = ABS( vtr_bbl(ji,jj) ) 283 ! 284 ! up -slope T-point (shelf bottom point) 285 zbtr = e1e2t_r(ji,ijs) / fse3t(ji,ijs,ikvs) 286 ztra = zv_bbl * ( ptrab(ji,ijd,ikvs,jn) - ptrab(ji,ijs,ikvs,jn) ) * zbtr 287 ptraa(ji,ijs,ikvs,jn) = ptraa(ji,ijs,ikvs,jn) + ztra 288 ! 289 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 290 zbtr = e1e2t_r(ji,ijd) / fse3t(ji,ijd,jk) 291 ztra = zv_bbl * ( ptrab(ji,ijd,jk+1,jn) - ptrab(ji,ijd,jk,jn) ) * zbtr 292 ptraa(ji,ijd,jk,jn) = ptraa(ji,ijd,jk,jn) + ztra 293 END DO 294 ! ! down-slope T-point (deep bottom point) 295 zbtr = e1e2t_r(ji,ijd) / fse3t(ji,ijd,ikvd) 296 ztra = zv_bbl * ( ptrab(ji,ijs,ikvs,jn) - ptrab(ji,ijd,ikvd,jn) ) * zbtr 297 ptraa(ji,ijd,ikvd,jn) = ptraa(ji,ijd,ikvd,jn) + ztra 298 ENDIF 299 END DO 300 ! 301 END DO 302 ! 303 END DO 304 ! 305 END SUBROUTINE tra_bbl_adv 306 307 SUBROUTINE bbl( kt, cdtype ) 308 !!---------------------------------------------------------------------- 309 !! *** ROUTINE bbl *** 310 !! 311 !! ** Purpose : Computes the bottom boundary horizontal and vertical 312 !! advection terms. 313 !! 314 !! ** Method : 315 !! * diffusive bbl (nn_bbl_ldf=1) : 316 !! When the product grad( rho) * grad(h) < 0 (where grad is an 317 !! along bottom slope gradient) an additional lateral 2nd order 318 !! diffusion along the bottom slope is added to the general 319 !! tracer trend, otherwise the additional trend is set to 0. 320 !! A typical value of ahbt is 2000 m2/s (equivalent to 321 !! a downslope velocity of 20 cm/s if the condition for slope 322 !! convection is satified) 323 !! * advective bbl (nn_bbl_adv=1 or 2) : 324 !! nn_bbl_adv = 1 use of the ocean velocity as bbl velocity 325 !! nn_bbl_adv = 2 follow Campin and Goosse (1999) implentation 326 !! i.e. transport proportional to the along-slope density gradient 327 !! 328 !! NB: the along slope density gradient is evaluated using the 329 !! local density (i.e. referenced at a common local depth). 330 !! 331 !! 332 !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 333 !! Campin, J.-M., and H. Goosse, 1999, Tellus, 412-430. 334 !!---------------------------------------------------------------------- 335 INTEGER , INTENT(in ) :: kt ! ocean time-step index 336 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 337 INTEGER :: ji, jj ! dummy loop indices 338 INTEGER :: ik ! temporary integers 339 INTEGER :: iis , iid , ijs , ijd ! - - 340 INTEGER :: ikus, ikud, ikvs, ikvd ! - - 341 REAL(wp) :: zsign, zsigna, zgbbl ! temporary scalars 342 REAL(wp) :: zgdrho, zt, zs, zh ! - - 343 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, ztb, zsb, zdep ! - - 344 !! 345 REAL(wp) :: fsalbt, fsbeta, pft, pfs, pfh ! statement function 346 !!----------------------- zv_bbl----------------------------------------------- 347 ! ratio alpha/beta = fsalbt : ratio of thermal over saline expension coefficients 348 ! ================ pft : potential temperature in degrees celcius 349 ! pfs : salinity anomaly (s-35) in psu 350 ! pfh : depth in meters 351 ! nn_eos = 0 (Jackett and McDougall 1994 formulation) 352 fsalbt( pft, pfs, pfh ) = & ! alpha/beta 353 ( ( ( -0.255019e-07 * pft + 0.298357e-05 ) * pft & 354 - 0.203814e-03 ) * pft & 355 + 0.170907e-01 ) * pft & 356 + 0.665157e-01 & 357 +(-0.678662e-05 * pfs - 0.846960e-04 * pft + 0.378110e-02 ) * pfs & 358 + ( ( - 0.302285e-13 * pfh & 359 - 0.251520e-11 * pfs & 360 + 0.512857e-12 * pft * pft ) * pfh & 361 - 0.164759e-06 * pfs & 362 +( 0.791325e-08 * pft - 0.933746e-06 ) * pft & 363 + 0.380374e-04 ) * pfh 364 fsbeta( pft, pfs, pfh ) = & ! beta 365 ( ( -0.415613e-09 * pft + 0.555579e-07 ) * pft & 366 - 0.301985e-05 ) * pft & 367 + 0.785567e-03 & 368 + ( 0.515032e-08 * pfs & 369 + 0.788212e-08 * pft - 0.356603e-06 ) * pfs & 370 +( ( 0.121551e-17 * pfh & 371 - 0.602281e-15 * pfs & 372 - 0.175379e-14 * pft + 0.176621e-12 ) * pfh & 373 + 0.408195e-10 * pfs & 374 + ( - 0.213127e-11 * pft + 0.192867e-09 ) * pft & 375 - 0.121555e-07 ) * pfh 376 !!---------------------------------------------------------------------- 377 378 ! !* bottom temperature, salinity, velocity and depth 379 IF( kt == nit000 ) THEN 380 IF(lwp) WRITE(numout,*) ' ' 381 IF(lwp) WRITE(numout,*) ' trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype, ' at time step ', kt 382 IF(lwp) WRITE(numout,*) ' ' 383 ENDIF 384 385 #if defined key_vectopt_loop 386 DO jj = 1, 1 ! vector opt. (forced unrolling) 387 DO ji = 1, jpij 388 #else 389 DO jj = 1, jpj 390 DO ji = 1, jpi 391 #endif 392 ik = mbkt(ji,jj) ! bottom T-level index 393 ztb (ji,jj) = tb(ji,jj,ik) ! bottom before T and S 394 zsb (ji,jj) = sb(ji,jj,ik) 395 zdep(ji,jj) = fsdept_0(ji,jj,ik) ! bottom T-level reference depth 396 ! 397 zub(ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity 398 zvb(ji,jj) = vn(ji,jj,mbkv(ji,jj)) 399 END DO 400 END DO 401 402 ! !-------------------! 403 IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! 404 ! !-------------------! 405 ! ! bbl diffusive fluxes 406 ! ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 407 # if defined key_vectopt_loop 408 DO jj = 1, 1 ! vector opt. (forced unrolling) 409 DO ji = 1, jpij-jpi 251 410 # else 252 411 DO jj = 1, jpjm1 253 412 DO ji = 1, jpim1 254 413 # endif 255 ! local 'density/temperature' gradient along i-bathymetric slope 256 zgdrho = ztnb(ji+1,jj) - ztnb(ji,jj) 257 ! sign of local i-gradient of density multiplied by the i-slope 258 zsign = SIGN( 0.5, - zgdrho * ( zdep(ji+1,jj) - zdep(ji,jj) ) ) 259 zki(ji,jj) = ( 0.5 - zsign ) * zahu(ji,jj) 414 ! ! i-direction 415 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! T, S anomalie, and depth 416 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 417 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 418 ! ! masked bbl i-gradient of density 419 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) ) & 420 & - ( zsb(ji+1,jj) - zsb(ji,jj) ) ) * umask(ji,jj,1) 421 ! 422 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of ( i-gradient * i-slope ) 423 ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj) ! masked diffusive flux coeff. 260 424 ! 261 ! local density gradient along j-bathymetric slope 262 zgdrho = ztnb(ji,jj+1) - ztnb(ji,jj) 263 ! sign of local j-gradient of density multiplied by the j-slope 264 zsign = sign( 0.5, -zgdrho * ( zdep(ji,jj+1) - zdep(ji,jj) ) ) 265 zkj(ji,jj) = ( 0.5 - zsign ) * zahv(ji,jj) 425 ! ! j-direction 426 zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) ) ! T, S anomalie, and depth 427 zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 428 zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 429 ! ! masked bbl j-gradient of density 430 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) ) & 431 & - ( zsb(ji,jj+1) - zsb(ji,jj) ) ) * vmask(ji,jj,1) 432 ! 433 zsign = SIGN( 0.5, -zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of ( j-gradient * j-slope ) 434 ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 435 ! 266 436 END DO 267 437 END DO 268 438 ! 269 CASE ( 2 ) !== Linear formulation function of temperature and salinity ==! 270 # if defined key_vectopt_loop 271 DO jj = 1, 1 272 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 273 # else 274 DO jj = 1, jpjm1 275 DO ji = 1, jpim1 276 # endif 277 ! local density gradient along i-bathymetric slope 278 zgdrho = - ( rn_beta *( zsnb(ji+1,jj) - zsnb(ji,jj) ) & 279 & - rn_alpha*( ztnb(ji+1,jj) - ztnb(ji,jj) ) ) 280 ! sign of local i-gradient of density multiplied by the i-slope 281 zsign = SIGN( 0.5, - zgdrho * ( zdep(ji+1,jj) - zdep(ji,jj) ) ) 282 zki(ji,jj) = ( 0.5 - zsign ) * zahu(ji,jj) 283 ! 284 ! local density gradient along j-bathymetric slope 285 zgdrho = - ( rn_beta *( zsnb(ji,jj+1) - zsnb(ji,jj) ) & 286 & - rn_alpha*( ztnb(ji,jj+1) - ztnb(ji,jj) ) ) 287 ! sign of local j-gradient of density multiplied by the j-slope 288 zsign = sign( 0.5, -zgdrho * ( zdep(ji,jj+1) - zdep(ji,jj) ) ) 289 zkj(ji,jj) = ( 0.5 - zsign ) * zahv(ji,jj) 439 ENDIF 440 441 442 ! !-------------------! 443 IF( nn_bbl_adv /= 0 ) THEN ! advective bbl ! 444 ! !-------------------! 445 SELECT CASE ( nn_bbl_adv ) !* bbl transport type 446 ! 447 CASE( 1 ) != use of upper velocity 448 DO jj = 2, jpjm1 ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 449 DO ji = 1, fs_jpim1 ! vector opt. 450 ! ! i-direction 451 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! T, S anomalie, and depth 452 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 453 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 454 ! ! masked bbl i-gradient of density 455 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji+1,jj) - ztb(ji,jj) ) & 456 & - ( zsb(ji+1,jj) - zsb(ji,jj) ) ) * umask(ji,jj,1) 457 ! 458 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope 459 zsigna= SIGN( 0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) ) ) ! sign of u * i-slope 460 ! 461 ! ! bbl velocity 462 utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 463 ! 464 ! ! j-direction 465 zt = 0.5 * ( ztb (ji,jj+1) + ztb (ji,jj) ) ! T, S anomalie, and depth 466 zs = 0.5 * ( zsb (ji,jj+1) + zsb (ji,jj) ) - 35.0 467 zh = 0.5 * ( zdep(ji,jj+1) + zdep(ji,jj) ) 468 ! ! masked bbl j-gradient of density 469 zgdrho = ( fsalbt( zt, zs, zh ) * ( ztb(ji,jj+1) - ztb(ji,jj) ) & 470 & - ( zsb(ji,jj+1) - zsb(ji,jj) ) ) * vmask(ji,jj,1) 471 zsign = SIGN( 0.5, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope 472 zsigna= SIGN( 0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) ) ) ! sign of u * i-slope 473 ! 474 ! ! bbl velocity 475 vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 476 END DO 290 477 END DO 291 END DO 292 ! 293 END SELECT 294 295 ! 2. Additional second order diffusive trends 296 ! ------------------------------------------- 297 298 ! first derivative (gradient) 299 # if defined key_vectopt_loop 300 jj = 1 301 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 302 # else 303 DO jj = 1, jpjm1 304 DO ji = 1, jpim1 305 # endif 306 zkx(ji,jj) = zki(ji,jj) * ( ztbb(ji+1,jj) - ztbb(ji,jj) ) 307 zkz(ji,jj) = zki(ji,jj) * ( zsbb(ji+1,jj) - zsbb(ji,jj) ) 308 309 zky(ji,jj) = zkj(ji,jj) * ( ztbb(ji,jj+1) - ztbb(ji,jj) ) 310 zkw(ji,jj) = zkj(ji,jj) * ( zsbb(ji,jj+1) - zsbb(ji,jj) ) 311 # if ! defined key_vectopt_loop 312 END DO 313 # endif 314 END DO 315 316 IF( cp_cfg == "orca" ) THEN 317 ! 318 SELECT CASE ( jp_cfg ) 319 ! ! ======================= 320 CASE ( 2 ) ! ORCA_R2 configuration 321 ! ! ======================= 322 ! Gibraltar enhancement of BBL 323 ij0 = 102 ; ij1 = 102 324 ii0 = 139 ; ii1 = 140 325 zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 326 zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 327 ! 328 ! Red Sea enhancement of BBL 329 ij0 = 88 ; ij1 = 88 330 ii0 = 161 ; ii1 = 162 331 zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e0 * zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 332 zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 10.e0 * zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 333 ! 334 ! ! ======================= 335 CASE ( 4 ) ! ORCA_R4 configuration 336 ! ! ======================= 337 ! Gibraltar enhancement of BBL 338 ij0 = 52 ; ij1 = 52 339 ii0 = 70 ; ii1 = 71 340 zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zkx( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 341 zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 4.e0 * zky( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) 342 ! 478 ! 479 CASE( 2 ) != bbl velocity = F( delta rho ) 480 zgbbl = grav * rn_gambbl 481 DO jj = 2, jpjm1 ! criteria: rho_up > rho_down 482 DO ji = 1, fs_jpim1 ! vector opt. 483 ! ! i-direction 484 ! down-slope T-point i/k-index (deep) & up-slope T-point i/k-index (shelf) 485 iid = ji + MAX( 0, mgrhu(ji,jj) ) ; iis = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 486 ikud = mbku_d(ji,jj) ; ikus = mbku(ji,jj) 487 ! 488 ! ! mid-depth density anomalie (up-slope minus down-slope) 489 zt = 0.5 * ( ztb (ji,jj) + ztb (ji+1,jj) ) ! mid slope depth of T, S, and depth 490 zs = 0.5 * ( zsb (ji,jj) + zsb (ji+1,jj) ) - 35.0 491 zh = 0.5 * ( zdep(ji,jj) + zdep(ji+1,jj) ) 492 zgdrho = fsbeta( zt, zs, zh ) & 493 & * ( fsalbt( zt, zs, zh ) * ( ztb(iid,jj) - ztb(iis,jj) ) & 494 & - ( zsb(iid,jj) - zsb(iis,jj) ) ) * umask(ji,jj,1) 495 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 496 ! 497 ! ! bbl transport (down-slope direction) 498 utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 499 ! 500 ! ! j-direction 501 ! down-slope T-point j/k-index (deep) & of the up -slope T-point j/k-index (shelf) 502 ijd = jj + MAX( 0, mgrhv(ji,jj) ) ; ijs = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 503 ikvd = mbkv_d(ji,jj) ; ikvs = mbkv(ji,jj) 504 ! 505 ! ! mid-depth density anomalie (up-slope minus down-slope) 506 zt = 0.5 * ( ztb (ji,jj) + ztb (ji,jj+1) ) ! mid slope depth of T, S, and depth 507 zs = 0.5 * ( zsb (ji,jj) + zsb (ji,jj+1) ) - 35.0 508 zh = 0.5 * ( zdep(ji,jj) + zdep(ji,jj+1) ) 509 zgdrho = fsbeta( zt, zs, zh ) & 510 & * ( fsalbt( zt, zs, zh ) * ( ztb(ji,ijd) - ztb(ji,ijs) ) & 511 & - ( zsb(ji,ijd) - zsb(ji,ijs) ) ) * vmask(ji,jj,1) 512 zgdrho = MAX( 0.e0, zgdrho ) ! only if shelf is denser than deep 513 ! 514 ! ! bbl transport (down-slope direction) 515 vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 516 END DO 517 END DO 343 518 END SELECT 344 !519 ! 345 520 ENDIF 346 347 348 ! second derivative (divergence) and add to the general tracer trend 349 # if defined key_vectopt_loop 350 DO jj = 1, 1 351 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling) 352 # else 353 DO jj = 2, jpjm1 354 DO ji = 2, jpim1 355 # endif 356 ik = max( mbathy(ji,jj)-1, 1 ) 357 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,ik) ) 358 zta = ( zkx(ji,jj) - zkx(ji-1,jj ) & 359 + zky(ji,jj) - zky(ji ,jj-1) ) * zbtr 360 zsa = ( zkz(ji,jj) - zkz(ji-1,jj ) & 361 + zkw(ji,jj) - zkw(ji ,jj-1) ) * zbtr 362 ta(ji,jj,ik) = ta(ji,jj,ik) + zta 363 sa(ji,jj,ik) = sa(ji,jj,ik) + zsa 364 END DO 365 END DO 366 367 IF( l_trdtra ) THEN ! save the BBL lateral diffusion trends for diagnostic 368 ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 369 ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 370 CALL trd_mod(ztrdt, ztrds, jptra_trd_bbl, 'TRA', kt) 371 ENDIF 372 373 IF(ln_ctl) CALL prt_ctl( tab3d_1=ta, clinfo1=' bbl - Ta: ', mask1=tmask, & 374 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 375 ! 376 END SUBROUTINE tra_bbl_dif 377 378 # if defined key_trabbl_adv 379 !!---------------------------------------------------------------------- 380 !! 'key_trabbl_adv' advective bottom boundary layer 381 !!---------------------------------------------------------------------- 382 # include "trabbl_adv.h90" 383 # else 384 !!---------------------------------------------------------------------- 385 !! Default option : NO advective bottom boundary layer 386 !!---------------------------------------------------------------------- 387 SUBROUTINE tra_bbl_adv (kt ) ! Empty routine 388 INTEGER, INTENT(in) :: kt 389 WRITE(*,*) 'tra_bbl_adv: You should not have seen this print! error?', kt 390 END SUBROUTINE tra_bbl_adv 391 # endif 521 ! 522 END SUBROUTINE bbl 523 392 524 393 525 SUBROUTINE tra_bbl_init … … 400 532 !! called by tra_bbl at the first timestep (nit000) 401 533 !!---------------------------------------------------------------------- 402 INTEGER :: ji, jj ! dummy loop indices 403 REAL(wp), DIMENSION(jpi,jpj) :: zmbk 404 405 NAMELIST/nambbl/ rn_ahtbbl 406 !!---------------------------------------------------------------------- 407 408 REWIND ( numnam ) ! Read Namelist nambbl : bottom boundary layer scheme 534 INTEGER :: ji, jj ! dummy loop indices 535 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integer 536 REAL(wp), DIMENSION(jpi,jpj) :: zmbk ! 2D workspace 537 538 NAMELIST/nambbl/ nn_bbl_ldf, nn_bbl_adv, rn_ahtbbl, rn_gambbl 539 !!---------------------------------------------------------------------- 540 541 REWIND ( numnam ) !* Read Namelist nambbl : bottom boundary layer scheme 409 542 READ ( numnam, nambbl ) 410 543 411 IF(lwp) THEN ! Parameter control and print544 IF(lwp) THEN !* Parameter control and print 412 545 WRITE(numout,*) 413 WRITE(numout,*) 'tra_bbl_init : '546 WRITE(numout,*) 'tra_bbl_init : bottom boundary layer initialisation' 414 547 WRITE(numout,*) '~~~~~~~~~~~~' 415 IF( lk_trabbl_dif ) WRITE(numout,*) ' * Diffusive Bottom Boundary Layer'416 IF( lk_trabbl_adv ) WRITE(numout,*) ' * Advective Bottom Boundary Layer'417 548 WRITE(numout,*) ' Namelist nambbl : set bbl parameters' 418 WRITE(numout,*) ' bottom boundary layer coef. rn_ahtbbl = ', rn_ahtbbl 549 WRITE(numout,*) ' diffusive bbl (=1) or not (=0) nn_bbl_ldf = ', nn_bbl_ldf 550 WRITE(numout,*) ' advective bbl (=1/2) or not (=0) nn_bbl_adv = ', nn_bbl_adv 551 WRITE(numout,*) ' diffusive bbl coefficient rn_ahtbbl = ', rn_ahtbbl, ' m2/s' 552 WRITE(numout,*) ' advective bbl coefficient rn_gambbl = ', rn_gambbl, ' s' 419 553 ENDIF 420 421 DO jj = 1, jpj 554 555 IF( nn_bbl_adv == 1 ) WRITE(numout,*) ' * Advective BBL using upper velocity' 556 IF( nn_bbl_adv == 2 ) WRITE(numout,*) ' * Advective BBL using velocity = F( delta rho)' 557 558 IF( nn_eos /= 0 ) CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' ) 559 560 561 ! !* inverse of surface of T-cells 562 e1e2t_r(:,:) = 1.0 / ( e1t(:,:) * e2t(:,:) ) 563 564 ! !* vertical index of bottom t-, u- and v-points 565 DO jj = 1, jpj ! bottom k-index of T-level 422 566 DO ji = 1, jpi 423 mbkt(ji,jj) = MAX( mbathy(ji,jj) - 1, 1 ) ! vertical index of the bottom ocean T-level567 mbkt(ji,jj) = MAX( mbathy(ji,jj) - 1, 1 ) 424 568 END DO 425 569 END DO 426 DO jj = 1, jpjm1 570 DO jj = 1, jpjm1 ! bottom k-index of u- (v-) level (shelf and deep) 427 571 DO ji = 1, jpim1 428 mbku(ji,jj) = MAX( MIN( mbathy(ji+1,jj ), mbathy(ji,jj) ) - 1, 1 ) 429 mbkv(ji,jj) = MAX( MIN( mbathy(ji ,jj+1), mbathy(ji,jj) ) - 1, 1 ) 572 mbku (ji,jj) = MAX( MIN( mbathy(ji+1,jj ), mbathy(ji,jj) ) - 1, 1 ) ! "shelf" 573 mbkv (ji,jj) = MAX( MIN( mbathy(ji ,jj+1), mbathy(ji,jj) ) - 1, 1 ) 574 mbku_d(ji,jj) = MAX( MAX( mbathy(ji+1,jj ), mbathy(ji,jj) ) - 1, 1 ) ! "deep" 575 mbkv_d(ji,jj) = MAX( MAX( mbathy(ji ,jj+1), mbathy(ji,jj) ) - 1, 1 ) 430 576 END DO 431 577 END DO 432 433 zmbk(:,:) = FLOAT( mbku (:,:) ) 434 CALL lbc_lnk(zmbk,'U',1.) 435 mbku(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 436 437 zmbk(:,:) = FLOAT( mbkv (:,:) ) 438 CALL lbc_lnk(zmbk,'V',1.) 439 mbkv(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 440 441 # if defined key_trabbl_adv 442 w_bbl(:,:,:) = 0.e0 ! initialisation of w_bbl to zero 443 # endif 578 zmbk(:,:) = FLOAT( mbku (:,:) ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 579 zmbk(:,:) = FLOAT( mbkv (:,:) ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 580 zmbk(:,:) = FLOAT( mbku_d(:,:) ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 581 zmbk(:,:) = FLOAT( mbkv_d(:,:) ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 582 583 DO jj = 1, jpj !* sign of grad(H) at u- and v-points 584 DO ji = 1, jpi 585 mgrhu(ji,jj) = INT( SIGN( 1.e0, fsdept_0(ji+1,jj,mbkt(ji+1,jj)) - fsdept_0(ji,jj,mbkt(ji,jj)) ) ) 586 mgrhv(ji,jj) = INT( SIGN( 1.e0, fsdept_0(ji,jj+1,mbkt(ji,jj+1)) - fsdept_0(ji,jj,mbkt(ji,jj)) ) ) 587 END DO 588 END DO 589 590 DO jj = 1, jpjm1 !* bbl thickness at u- (v-) point 591 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0) 592 e3u_bbl_0(ji,jj) = MIN( fse3u_0(ji,jj,mbkt(ji+1,jj )), fse3u_0(ji,jj,mbkt(ji,jj)) ) 593 e3v_bbl_0(ji,jj) = MIN( fse3v_0(ji,jj,mbkt(ji ,jj+1)), fse3v_0(ji,jj,mbkt(ji,jj)) ) 594 END DO 595 END DO 596 CALL lbc_lnk( e3u_bbl_0, 'U', 1. ) ; CALL lbc_lnk( e3v_bbl_0, 'V', 1. ) ! lateral boundary conditions 597 598 ! !* masked diffusive flux coefficients 599 ahu_bbl_0(:,:) = rn_ahtbbl * e2u(:,:) * e3u_bbl_0(:,:) / e1u(:,:) * umask(:,:,1) 600 ahv_bbl_0(:,:) = rn_ahtbbl * e1v(:,:) * e3v_bbl_0(:,:) / e2v(:,:) * vmask(:,:,1) 601 602 IF( cp_cfg == "orca" ) THEN !* ORCA configuration : regional enhancement of ah_bbl 603 ! 604 SELECT CASE ( jp_cfg ) 605 CASE ( 2 ) ! ORCA_R2 606 ij0 = 102 ; ij1 = 102 ! Gibraltar enhancement of BBL 607 ii0 = 139 ; ii1 = 140 608 ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 609 ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 610 ! 611 ij0 = 88 ; ij1 = 88 ! Red Sea enhancement of BBL 612 ii0 = 161 ; ii1 = 162 613 ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 614 ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 615 ! 616 CASE ( 4 ) ! ORCA_R4 617 ij0 = 52 ; ij1 = 52 ! Gibraltar enhancement of BBL 618 ii0 = 70 ; ii1 = 71 619 ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 620 ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 621 END SELECT 622 ! 623 ENDIF 624 ! 625 l_bbl = .TRUE. !: flag to compute bbl coef and transport 444 626 ! 445 627 END SUBROUTINE tra_bbl_init … … 449 631 !! Dummy module : No bottom boundary layer scheme 450 632 !!---------------------------------------------------------------------- 451 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl_dif = .FALSE. !: diff bbl flag 452 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl_adv = .FALSE. !: adv bbl flag 633 LOGICAL, PUBLIC, PARAMETER :: lk_trabbl = .FALSE. !: bbl flag 453 634 CONTAINS 454 SUBROUTINE tra_bbl_dif( kt ) ! Empty routine 455 WRITE(*,*) 'tra_bbl_dif: You should not have seen this print! error?', kt 456 END SUBROUTINE tra_bbl_dif 457 SUBROUTINE tra_bbl_adv( kt ) ! Empty routine 458 WRITE(*,*) 'tra_bbl_adv: You should not have seen this print! error?', kt 459 END SUBROUTINE tra_bbl_adv 635 SUBROUTINE tra_bbl( kt ) ! Empty routine 636 WRITE(*,*) 'tra_bbl: You should not have seen this print! error?', kt 637 END SUBROUTINE tra_bbl 460 638 #endif 461 639 -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/tradmp.F90
r1601 r2024 13 13 !! NEMO 1.0 ! 2002-08 (G. Madec, E. Durand) free form + modules 14 14 !! 3.2 ! 2009-08 (G. Madec, C. Talandier) DOCTOR norm for namelist parameter 15 !! 3.3 ! 2010-06 (C. Ethe, G. Madec) merge TRA-TRC 15 16 !!---------------------------------------------------------------------- 16 17 #if defined key_tradmp || defined key_esopa … … 26 27 USE oce ! ocean dynamics and tracers variables 27 28 USE dom_oce ! ocean space and time domain variables 28 USE trdmod ! ocean active tracers trends29 USE trd mod_oce ! ocean variables trends29 USE trdmod_oce ! ocean space and time domain variables 30 USE trdtra ! ocean space and time domain variables 30 31 USE zdf_oce ! ocean vertical physics 31 32 USE phycst ! Define parameters for the routines … … 40 41 PRIVATE 41 42 42 PUBLIC tra_dmp ! routine called by step.F90 43 PUBLIC tra_dmp ! routine called by step.F90 44 PUBLIC tra_dmp_init ! routine called by opa.F90 45 PUBLIC dtacof ! routine called by tradmp.F90 and trcdmp.F90 46 PUBLIC dtacof_zoom ! routine called by tradmp.F90 and trcdmp.F90 43 47 44 48 #if ! defined key_agrif … … 86 90 !! ** Action : - (ta,sa) tracer trends updated with the damping trend 87 91 !!---------------------------------------------------------------------- 88 USE oce, ONLY : ztrdt => ua ! use ua as 3D workspace89 USE oce, ONLY : ztrds => va ! use va as 3D workspace90 !!91 92 INTEGER, INTENT(in) :: kt ! ocean time-step index 92 93 !! 93 94 INTEGER :: ji, jj, jk ! dummy loop indices 94 !!----------------------------------------------------------------------95 96 IF( kt == nit000 ) CALL tra_dmp_init ! Initialization97 98 IF( l_trdtra ) THEN !Save ta and sa trends99 ztrdt(:,:,:) = ta(:,:,:)100 ztrds(:,:,:) = sa(:,:,:)95 REAL(wp) :: zta, zsa 96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 97 !!---------------------------------------------------------------------- 98 99 IF( l_trdtra ) THEN !* Save ta and sa trends 100 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 101 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsa(:,:,:,jp_sal) 101 102 ENDIF 102 103 … … 107 108 DO jj = 2, jpjm1 108 109 DO ji = fs_2, fs_jpim1 ! vector opt. 109 ta(ji,jj,jk) = ta(ji,jj,jk) + resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tb(ji,jj,jk) ) 110 sa(ji,jj,jk) = sa(ji,jj,jk) + resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - sb(ji,jj,jk) ) 110 zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 111 zsa = resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_sal) ) 112 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 113 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 111 114 END DO 112 115 END DO … … 118 121 DO ji = fs_2, fs_jpim1 ! vector opt. 119 122 IF( avt(ji,jj,jk) <= 5.e-4 ) THEN 120 ta(ji,jj,jk) = ta(ji,jj,jk) + resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tb(ji,jj,jk) ) 121 sa(ji,jj,jk) = sa(ji,jj,jk) + resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - sb(ji,jj,jk) ) 123 zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 124 zsa = resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_sal) ) 125 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 126 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 122 127 ENDIF 123 128 END DO … … 130 135 DO ji = fs_2, fs_jpim1 ! vector opt. 131 136 IF( fsdept(ji,jj,jk) >= hmlp (ji,jj) ) THEN 132 ta(ji,jj,jk) = ta(ji,jj,jk) + resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tb(ji,jj,jk) ) 133 sa(ji,jj,jk) = sa(ji,jj,jk) + resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - sb(ji,jj,jk) ) 137 zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 138 zsa = resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_sal) ) 139 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta 140 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 134 141 ENDIF 135 142 END DO … … 140 147 141 148 IF( l_trdtra ) THEN ! trend diagnostic 142 ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 143 ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 144 CALL trd_mod( ztrdt, ztrds, jptra_trd_dmp, 'TRA', kt ) 149 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 150 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 151 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_dmp, ztrdt ) 152 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_dmp, ztrds ) 153 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 145 154 ENDIF 146 155 ! ! Control print 147 IF(ln_ctl) CALL prt_ctl( tab3d_1=t a, clinfo1=' dmp - Ta: ', mask1=tmask, &148 & tab3d_2= sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )156 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' dmp - Ta: ', mask1=tmask, & 157 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 149 158 ! 150 159 END SUBROUTINE tra_dmp … … 200 209 201 210 ! ! Damping coefficients initialization 202 IF( lzoom ) THEN ; CALL dtacof_zoom 203 ELSE ; CALL dtacof 211 IF( lzoom ) THEN ; CALL dtacof_zoom( resto ) 212 ELSE ; CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, & 213 & nn_file, 'TRA' , resto ) 204 214 ENDIF 205 215 ! … … 207 217 208 218 209 SUBROUTINE dtacof_zoom 219 SUBROUTINE dtacof_zoom( presto ) 210 220 !!---------------------------------------------------------------------- 211 221 !! *** ROUTINE dtacof_zoom *** … … 220 230 !! ** Action : - resto, the damping coeff. for T and S 221 231 !!---------------------------------------------------------------------- 232 !! * Arguments 233 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: presto !: restoring coeff. (s-1) 234 ! 222 235 INTEGER :: ji, jj, jk, jn ! dummy loop indices 223 236 REAL(wp) :: zlat, zlat0, zlat1, zlat2 ! temporary scalar … … 233 246 zfact(:) = zfact(:) / ( 5. * rday ) ! 5 days max restoring time scale 234 247 235 resto(:,:,:) = 0.e0248 presto(:,:,:) = 0.e0 236 249 237 250 ! damping along the forced closed boundary over 6 grid-points 238 251 DO jn = 1, 6 239 IF( lzoom_w ) resto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : ) = zfact(jn) ! west closed240 IF( lzoom_s ) resto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : ) = zfact(jn) ! south closed241 IF( lzoom_e ) resto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn) ! east closed242 IF( lzoom_n ) resto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn) ! north closed252 IF( lzoom_w ) presto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : ) = zfact(jn) ! west closed 253 IF( lzoom_s ) presto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : ) = zfact(jn) ! south closed 254 IF( lzoom_e ) presto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn) ! east closed 255 IF( lzoom_n ) presto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn) ! north closed 243 256 END DO 244 257 … … 252 265 ! 253 266 ! ! Initialization : 254 resto(:,:,:) = 0.e0267 presto(:,:,:) = 0.e0 255 268 zlat0 = 10. ! zlat0 : latitude strip where resto decreases 256 269 zlat1 = 30. ! zlat1 : resto = 1 before zlat1 … … 262 275 zlat = ABS( gphit(ji,jj) ) 263 276 IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 264 resto(ji,jj,jk) = 0.5 * ( 1./(5.*rday) ) * ( 1. - cos(rpi*(zlat2-zlat)/zlat0) )277 presto(ji,jj,jk) = 0.5 * ( 1./(5.*rday) ) * ( 1. - cos(rpi*(zlat2-zlat)/zlat0) ) 265 278 ELSEIF( zlat < zlat1 ) THEN 266 resto(ji,jj,jk) = 1./(5.*rday)279 presto(ji,jj,jk) = 1./(5.*rday) 267 280 ENDIF 268 281 END DO … … 272 285 ENDIF 273 286 ! ! Mask resto array 274 resto(:,:,:) =resto(:,:,:) * tmask(:,:,:)287 presto(:,:,:) = presto(:,:,:) * tmask(:,:,:) 275 288 ! 276 289 END SUBROUTINE dtacof_zoom 277 290 278 291 279 SUBROUTINE dtacof 292 SUBROUTINE dtacof( kn_hdmp, pn_surf, pn_bot, pn_dep, & 293 & kn_file, cdtype , presto ) 280 294 !!---------------------------------------------------------------------- 281 295 !! *** ROUTINE dtacof *** … … 291 305 USE iom 292 306 USE ioipsl 293 !! 307 !! * Arguments 308 INTEGER , INTENT(in ) :: kn_hdmp !: damping option 309 REAL(wp) , INTENT(in ) :: pn_surf !: surface time scale (days) 310 REAL(wp) , INTENT(in ) :: pn_bot !: bottom time scale (days) 311 REAL(wp) , INTENT(in ) :: pn_dep !: depth of transition (meters) 312 INTEGER , INTENT(in ) :: kn_file !: save the damping coef on a file or not 313 CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 314 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: presto !: restoring coeff. (s-1) 315 ! 294 316 INTEGER :: ji, jj, jk ! dummy loop indices 295 317 INTEGER :: ii0, ii1, ij0, ij1 ! - - … … 302 324 REAL(wp), DIMENSION(jpi,jpj) :: zmrs 303 325 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdct 326 CHARACTER(len=20) :: cfile 304 327 !!---------------------------------------------------------------------- 305 328 … … 313 336 314 337 ! ... Initialization : 315 resto(:,:,:) = 0.e0 316 317 ! !-----------------------------------------! 318 IF( nn_hdmp > 0 ) THEN ! Damping poleward of 'nn_hdmp' degrees ! 338 presto(:,:,:) = 0.e0 339 ! 340 IF( kn_hdmp > 0 ) THEN ! Damping poleward of 'nn_hdmp' degrees ! 319 341 ! !-----------------------------------------! 320 342 IF(lwp) WRITE(numout,*) 321 IF(lwp) WRITE(numout,*) ' Damping poleward of ', nn_hdmp,' deg.'343 IF(lwp) WRITE(numout,*) ' Damping poleward of ', kn_hdmp,' deg.' 322 344 ! 323 345 CALL iom_open ( 'dist.coast.nc', icot, ldstop = .FALSE. ) … … 333 355 zinfl = 1000.e3 ! distance of influence for damping term 334 356 zlat0 = 10. ! latitude strip where resto decreases 335 zlat1 = REAL( nn_hdmp ) ! resto = 0 between -zlat1 and zlat1357 zlat1 = REAL( kn_hdmp ) ! resto = 0 between -zlat1 and zlat1 336 358 zlat2 = zlat1 + zlat0 ! resto increases from 0 to 1 between |zlat1| and |zlat2| 337 359 … … 340 362 zlat = ABS( gphit(ji,jj) ) 341 363 IF ( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 342 resto(ji,jj,1) = 0.5 * ( 1. - cos(rpi*(zlat-zlat1)/zlat0 ) )364 presto(ji,jj,1) = 0.5 * ( 1. - cos(rpi*(zlat-zlat1)/zlat0 ) ) 343 365 ELSEIF ( zlat > zlat2 ) THEN 344 resto(ji,jj,1) = 1.366 presto(ji,jj,1) = 1. 345 367 ENDIF 346 368 END DO 347 369 END DO 348 370 349 IF ( nn_hdmp == 20 ) THEN ! North Indian ocean (20N/30N x 45E/100E) : resto=0371 IF ( kn_hdmp == 20 ) THEN ! North Indian ocean (20N/30N x 45E/100E) : resto=0 350 372 DO jj = 1, jpj 351 373 DO ji = 1, jpi … … 353 375 zlon = MOD( glamt(ji,jj), 360. ) 354 376 IF ( zlat1 < zlat .AND. zlat < zlat2 .AND. 45. < zlon .AND. zlon < 100. ) THEN 355 resto(ji,jj,1) = 0.e0377 presto(ji,jj,1) = 0.e0 356 378 ENDIF 357 379 END DO … … 359 381 ENDIF 360 382 361 zsdmp = 1./( rn_surf * rday)362 zbdmp = 1./( rn_bot * rday)383 zsdmp = 1./(pn_surf * rday) 384 zbdmp = 1./(pn_bot * rday) 363 385 DO jk = 2, jpkm1 364 386 DO jj = 1, jpj … … 366 388 zdct(ji,jj,jk) = MIN( zinfl, zdct(ji,jj,jk) ) 367 389 ! ... Decrease the value in the vicinity of the coast 368 resto(ji,jj,jk) =resto(ji,jj,1) * 0.5 * ( 1. - COS( rpi*zdct(ji,jj,jk)/zinfl) )390 presto(ji,jj,jk) = presto(ji,jj,1) * 0.5 * ( 1. - COS( rpi*zdct(ji,jj,jk)/zinfl) ) 369 391 ! ... Vertical variation from zsdmp (sea surface) to zbdmp (bottom) 370 resto(ji,jj,jk) = resto(ji,jj,jk) * ( zbdmp + (zsdmp-zbdmp)*EXP(-fsdept(ji,jj,jk)/rn_dep) )392 presto(ji,jj,jk) = presto(ji,jj,jk) * ( zbdmp + (zsdmp-zbdmp)*EXP(-fsdept(ji,jj,jk)/pn_dep) ) 371 393 END DO 372 394 END DO … … 376 398 377 399 378 IF( cp_cfg == "orca" .AND. ( nn_hdmp > 0 .OR. nn_hdmp == -1 ) ) THEN400 IF( cp_cfg == "orca" .AND. ( kn_hdmp > 0 .OR. kn_hdmp == -1 ) ) THEN 379 401 380 402 ! ! ========================= … … 465 487 zmrs( ji , mj0(ij0):mj1(ij1) ) = 0.1 * ABS( FLOAT(ji - mi1(ii1)) ) 466 488 END DO 467 zsdmp = 1./( rn_surf * rday)468 zbdmp = 1./( rn_bot* rday)489 zsdmp = 1./(pn_surf * rday) 490 zbdmp = 1./(pn_bot * rday) 469 491 DO jk = 1, jpk 470 zhfac (jk) = ( zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(1,1,jk)/ rn_dep) )492 zhfac (jk) = ( zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(1,1,jk)/pn_dep) ) 471 493 END DO 472 494 ! ! ======================== … … 478 500 479 501 DO jk = 1, jpkm1 480 resto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1. - zmrs(:,:) ) *resto(:,:,jk)502 presto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1. - zmrs(:,:) ) * presto(:,:,jk) 481 503 END DO 482 504 483 505 ! Mask resto array and set to 0 first and last levels 484 resto(:,:, : ) =resto(:,:,:) * tmask(:,:,:)485 resto(:,:, 1 ) = 0.e0486 resto(:,:,jpk) = 0.e0506 presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:) 507 presto(:,:, 1 ) = 0.e0 508 presto(:,:,jpk) = 0.e0 487 509 ! !--------------------! 488 510 ELSE ! No damping ! … … 492 514 493 515 ! !--------------------------------! 494 IF( nn_file == 1 ) THEN ! save damping coef. in a file !516 IF( kn_file == 1 ) THEN ! save damping coef. in a file ! 495 517 ! !--------------------------------! 496 518 IF(lwp) WRITE(numout,*) ' create damping.coeff.nc file' 497 CALL iom_open ( 'damping.coeff', inum0, ldwrt = .TRUE., kiolib = jprstlib ) 498 CALL iom_rstput( 0, 0, inum0, 'Resto', resto ) 519 IF( cdtype == 'TRA' ) cfile = 'damping.coeff' 520 IF( cdtype == 'TRC' ) cfile = 'damping.coeff.trc' 521 cfile = TRIM( cfile ) 522 CALL iom_open ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib ) 523 CALL iom_rstput( 0, 0, inum0, 'Resto', presto ) 499 524 CALL iom_close ( inum0 ) 500 525 ENDIF -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf.F90
r1601 r2024 4 4 !! Ocean Active tracers : lateral diffusive trends 5 5 !!===================================================================== 6 !! History : 9.0 ! 05-11 (G. Madec) Original code 6 !! History : 9.0 ! 2005-11 (G. Madec) Original code 7 !! NEMO 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA 7 8 !!---------------------------------------------------------------------- 8 9 … … 21 22 USE traldf_iso ! lateral mixing (tra_ldf_iso routine) 22 23 USE traldf_lap ! lateral mixing (tra_ldf_lap routine) 23 USE trdmod ! ocean active tracers trends24 USE trd mod_oce ! ocean variables trends24 USE trdmod_oce ! ocean space and time domain 25 USE trdtra ! ocean active tracers trends 25 26 USE prtctl ! Print control 26 27 USE in_out_manager ! I/O manager … … 31 32 PRIVATE 32 33 33 PUBLIC tra_ldf ! called by step.F9034 35 INTEGER, PUBLIC :: nldf = 0 ! type of lateral diffusion used defined from ln_traldf_... namlist logicals)36 ! (need to be public to be used in vertical diffusion routine)34 PUBLIC tra_ldf ! called by step.F90 35 PUBLIC tra_ldf_init ! called by opa.F90 36 ! 37 INTEGER :: nldf = 0 ! type of lateral diffusion used defined from ln_traldf_... namlist logicals) 37 38 #if defined key_traldf_ano 38 39 REAL, DIMENSION(jpi,jpj,jpk) :: t0_ldf, s0_ldf ! lateral diffusion trends of T & S … … 60 61 INTEGER, INTENT( in ) :: kt ! ocean time-step index 61 62 !! 62 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztrdt, ztrds ! 3D temporary workspace 63 !!---------------------------------------------------------------------- 64 65 IF( kt == nit000 ) CALL ldf_ctl ! initialisation & control of options 66 67 IF( l_trdtra ) THEN ! temporary save of ta and sa trends 68 ztrdt(:,:,:) = ta(:,:,:) 69 ztrds(:,:,:) = sa(:,:,:) 70 ENDIF 63 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 64 REAL(wp), DIMENSION(jpi,jpj,jpts) :: zgtsu, zgtsv 65 !!---------------------------------------------------------------------- 66 67 IF( l_trdtra ) THEN !* Save ta and sa trends 68 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 69 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsa(:,:,:,jp_sal) 70 ENDIF 71 72 zgtsu(:,:,jp_tem) = gtu(:,:) ; zgtsu(:,:,jp_sal) = gsu(:,:) 73 zgtsv(:,:,jp_tem) = gtv(:,:) ; zgtsv(:,:,jp_sal) = gsv(:,:) 71 74 72 75 SELECT CASE ( nldf ) ! compute lateral mixing trend and add it to the general trend 73 CASE ( 0 ) ; CALL tra_ldf_lap ( kt ) ! iso-level laplacian 74 CASE ( 1 ) ; CALL tra_ldf_iso ( kt ) ! rotated laplacian (except dk[ dk[.] ] part) 75 CASE ( 2 ) ; CALL tra_ldf_bilap ( kt ) ! iso-level bilaplacian 76 CASE ( 3 ) ; CALL tra_ldf_bilapg( kt ) ! s-coord. horizontal bilaplacian 76 CASE ( 0 ) ; CALL tra_ldf_lap ( kt , 'TRA', zgtsu, zgtsv, & 77 & tsb, tsa , jpts ) ! iso-level laplacian 78 CASE ( 1 ) ; CALL tra_ldf_iso ( kt , 'TRA', zgtsu, zgtsv, & 79 & tsb, tsa , jpts , ahtb0 ) ! rotated laplacian 80 CASE ( 2 ) ; CALL tra_ldf_bilap ( kt , 'TRA', zgtsu, zgtsv, & 81 & tsb, tsa , jpts ) ! iso-level bilaplacian 82 CASE ( 3 ) ; CALL tra_ldf_bilapg( kt , 'TRA', tsb, tsa, jpts ) ! s-coord. horizontal bilaplacian 77 83 ! 78 84 CASE ( -1 ) ! esopa: test all possibility with control print 79 CALL tra_ldf_lap ( kt ) 80 CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf0 - Ta: ', mask1=tmask, & 81 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 82 CALL tra_ldf_iso ( kt ) 83 CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf1 - Ta: ', mask1=tmask, & 84 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 85 CALL tra_ldf_bilap ( kt ) 86 CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf2 - Ta: ', mask1=tmask, & 87 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 88 CALL tra_ldf_bilapg ( kt ) 89 CALL prt_ctl( tab3d_1=ta, clinfo1=' ldf3 - Ta: ', mask1=tmask, & 90 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 85 CALL tra_ldf_lap ( kt , 'TRA', zgtsu, zgtsv, & 86 & tsb, tsa , jpts ) 87 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf0 - Ta: ', mask1=tmask, & 88 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 89 CALL tra_ldf_iso ( kt , 'TRA', zgtsu, zgtsv, & 90 & tsb, tsa , jpts , ahtb0 ) 91 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf1 - Ta: ', mask1=tmask, & 92 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 93 CALL tra_ldf_bilap ( kt , 'TRA', zgtsu, zgtsv, & 94 & tsb, tsa , jpts ) 95 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf2 - Ta: ', mask1=tmask, & 96 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 97 CALL tra_ldf_bilapg( kt , 'TRA', tsb, tsa, jpts ) 98 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf3 - Ta: ', mask1=tmask, & 99 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 91 100 END SELECT 92 101 93 102 #if defined key_traldf_ano 94 t a(:,:,:) = ta(:,:,:) - t0_ldf(:,:,:) ! anomaly: substract the reference diffusivity95 sa(:,:,:) = sa(:,:,:) - s0_ldf(:,:,:)103 tsa(:,:,:,jp_tem) = tsa(:,:,:,jp_tem) - t0_ldf(:,:,:) ! anomaly: substract the reference diffusivity 104 tsa(:,:,:,jp_sal) = tsa(:,:,:,jp_sal) - s0_ldf(:,:,:) 96 105 #endif 106 97 107 IF( l_trdtra ) THEN ! save the horizontal diffusive trends for further diagnostics 98 ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 99 ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 100 CALL trd_mod( ztrdt, ztrds, jptra_trd_ldf, 'TRA', kt ) 108 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 109 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 110 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_ldf, ztrdt ) 111 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_ldf, ztrds ) 112 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 101 113 ENDIF 102 114 ! ! print mean trends (used for debugging) 103 IF(ln_ctl) CALL prt_ctl( tab3d_1=t a, clinfo1=' ldf - Ta: ', mask1=tmask, &104 & tab3d_2= sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )115 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf - Ta: ', mask1=tmask, & 116 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 105 117 ! 106 118 END SUBROUTINE tra_ldf 107 119 108 120 109 SUBROUTINE ldf_ctl110 !!---------------------------------------------------------------------- 111 !! *** ROUTINE ldf_ctl***121 SUBROUTINE tra_ldf_init 122 !!---------------------------------------------------------------------- 123 !! *** ROUTINE tra_ldf_init *** 112 124 !! 113 125 !! ** Purpose : Choice of the operator for the lateral tracer diffusion … … 135 147 IF(lwp) THEN ! Namelist print 136 148 WRITE(numout,*) 137 WRITE(numout,*) 'tra :ldf_ctl: lateral tracer diffusive operator'149 WRITE(numout,*) 'tra_ldf_init : lateral tracer diffusive operator' 138 150 WRITE(numout,*) '~~~~~~~~~~~' 139 151 WRITE(numout,*) ' Namelist namtra_ldf : set lateral mixing parameters (type, direction, coefficients)' … … 225 237 CALL ldf_ano 226 238 ! 227 END SUBROUTINE ldf_ctl239 END SUBROUTINE tra_ldf_init 228 240 229 241 #if defined key_traldf_ano … … 271 283 t0_ldf(:,:,:) = 0.e0 272 284 s0_ldf(:,:,:) = 0.e0 273 ztb (:,:,:) = t b (:,:,:)274 zsb (:,:,:) = sb (:,:,:)275 ua (:,:,:) = t a (:,:,:)276 va (:,:,:) = sa (:,:,:)285 ztb (:,:,:) = tsb (:,:,:,jp_tem) 286 zsb (:,:,:) = tsb (:,:,:,jp_sal) 287 ua (:,:,:) = tsa (:,:,:,jp_tem) 288 va (:,:,:) = tsa (:,:,:,jp_sal) 277 289 zavt (:,:,:) = avt(:,:,:) 278 290 IF( lk_zdfddm ) THEN CALL ctl_stop( ' key_traldf_ano with key_zdfddm not implemented' ) 279 291 ! set tb, sb to reference values and avr to zero 280 t b (:,:,:) = zt_ref(:,:,:)281 sb (:,:,:) = zs_ref(:,:,:)282 t a (:,:,:) = 0.e0283 sa (:,:,:) = 0.e0284 avt(:,:,:) = 0.e0292 tsb (:,:,:,jp_tem) = zt_ref(:,:,:) 293 tsb (:,:,:,jp_sal) = zs_ref(:,:,:) 294 tsa (:,:,:,jp_tem) = 0.e0 295 tsa (:,:,:,jp_sal) = 0.e0 296 avt(:,:,:) = 0.e0 285 297 286 298 ! Compute the ldf trends … … 295 307 IF( neuler == 1) z12 = 1.e0 296 308 IF( ln_zdfexp ) THEN ! ta,sa are the trends 297 t0_ldf(:,:,:) = t a(:,:,:)298 s0_ldf(:,:,:) = sa(:,:,:)309 t0_ldf(:,:,:) = tsa(:,:,:,jp_tem) 310 s0_ldf(:,:,:) = tsa(:,:,:,jp_sal) 299 311 ELSE 300 312 DO jk = 1, jpkm1 301 t0_ldf(:,:,jk) = ( t a(:,:,jk) - tb(:,:,jk) ) / ( z12 *rdttra(jk) )302 s0_ldf(:,:,jk) = ( sa(:,:,jk) - tb(:,:,jk) ) / ( z12 *rdttra(jk) )313 t0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / ( z12 *rdttra(jk) ) 314 s0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / ( z12 *rdttra(jk) ) 303 315 END DO 304 316 ENDIF 305 t b (:,:,:) = ztb (:,:,:)306 sb (:,:,:) = zsb (:,:,:)307 t a (:,:,:) = ua (:,:,:)308 sa (:,:,:) = va (:,:,:)309 avt (:,:,:)= zavt(:,:,:)317 tsb(:,:,:,jp_tem) = ztb (:,:,:) 318 tsb(:,:,:,jp_sal) = zsb (:,:,:) 319 tsa(:,:,:,jp_tem) = ua (:,:,:) 320 tsa(:,:,:,jp_sal) = va (:,:,:) 321 avt(:,:,:) = zavt(:,:,:) 310 322 ! 311 323 END SUBROUTINE ldf_ano -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_bilap.F90
r1152 r2024 2 2 !!============================================================================== 3 3 !! *** MODULE traldf_bilap *** 4 !! Ocean active tracers: horizontal component of the lateral tracer mixing trend 4 !! Ocean tracers: horizontal component of the lateral tracer mixing trend 5 !!============================================================================== 6 !! History : ! 91-11 (G. Madec) Original code 7 !! ! 93-03 (M. Guyon) symetrical conditions 8 !! ! 95-11 (G. Madec) suppress volumetric scale factors 9 !! ! 96-01 (G. Madec) statement function for e3 10 !! ! 96-01 (M. Imbard) mpp exchange 11 !! ! 97-07 (G. Madec) optimization, and ahtt 12 !! 8.5 ! 02-08 (G. Madec) F90: Free form and module 13 !! 9.0 ! 04-08 (C. Talandier) New trends organization 14 !! ! 05-11 (G. Madec) zps or sco as default option 15 !! 3.3 ! 10-05 (C. Ethe, G. Madec) merge TRC-TRA 5 16 !!============================================================================== 6 17 … … 13 24 USE dom_oce ! ocean space and time domain 14 25 USE ldftra_oce ! ocean tracer lateral physics 15 USE trdmod ! ocean active tracers trends16 USE trdmod_oce ! ocean variables trends17 26 USE in_out_manager ! I/O manager 18 27 USE ldfslp ! iso-neutral slopes 19 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 20 29 USE diaptr ! poleward transport diagnostics 21 USE prtctl ! Print control22 30 23 31 IMPLICIT NONE … … 39 47 40 48 CONTAINS 41 42 SUBROUTINE tra_ldf_bilap( kt ) 49 50 SUBROUTINE tra_ldf_bilap( kt , cdtype, pgtu, pgtv, & 51 & ptrab, ptraa , kjpt ) 43 52 !!---------------------------------------------------------------------- 44 53 !! *** ROUTINE tra_ldf_bilap *** 45 54 !! 46 !! ** Purpose : Compute the before horizontal tracer (t & s)diffusive55 !! ** Purpose : Compute the before horizontal tracer diffusive 47 56 !! trend and add it to the general trend of tracer equation. 48 57 !! 49 58 !! ** Method : 4th order diffusive operator along model level surfaces 50 59 !! evaluated using before fields (forward time scheme). The hor. 51 !! diffusive trends of temperature (idem for salinity)is given by:60 !! diffusive trends is given by: 52 61 !! Laplacian of tb: 53 62 !! zlt = 1/(e1t*e2t*e3t) { di-1[ e2u*e3u/e1u di(tb) ] … … 59 68 !! difft = 1/(e1t*e2t*e3t) { di-1[ e2u*e3u/e1u di(zlt) ] 60 69 !! + dj-1[ e1v*e3v/e2v dj(zlt) ] } 61 !! Note: if key_zco defined, e3t=e3u=e3v, they are simplified.62 70 !! 63 !! Add this trend to the general trend (ta,sa):64 !! ( ta,sa) = (ta,sa) + ( difft , diffs)71 !! Add this trend to the general trend 72 !! (ptraa) = (ptraa) + ( difft ) 65 73 !! 66 !! ** Action : - Update (ta,sa)arrays with the before iso-level74 !! ** Action : - Update ptraa arrays with the before iso-level 67 75 !! biharmonic mixing trend. 68 !!69 !! History :70 !! ! 91-11 (G. Madec) Original code71 !! ! 93-03 (M. Guyon) symetrical conditions72 !! ! 95-11 (G. Madec) suppress volumetric scale factors73 !! ! 96-01 (G. Madec) statement function for e374 !! ! 96-01 (M. Imbard) mpp exchange75 !! ! 97-07 (G. Madec) optimization, and ahtt76 !! 8.5 ! 02-08 (G. Madec) F90: Free form and module77 !! 9.0 ! 04-08 (C. Talandier) New trends organization78 !! ! 05-11 (G. Madec) zps or sco as default option79 76 !!---------------------------------------------------------------------- 80 !! * Modules used 81 USE oce , ztu => ua, & ! use ua as workspace 82 & ztv => va ! use va as workspace 83 84 !! * Arguments 85 INTEGER, INTENT( in ) :: kt ! ocean time-step index 86 87 !! * Local declarations 88 INTEGER :: ji, jj, jk ! dummy loop indices 89 INTEGER :: iku, ikv ! temporary integers 90 REAL(wp) :: zta, zsa ! temporary scalars 77 !!* Module used 78 USE oce , ztu => ua ! use ua as workspace 79 USE oce , ztv => va ! use va as workspace 80 !!* Arguments 81 INTEGER , INTENT(in ) :: kt ! ocean time-step index 82 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 83 INTEGER , INTENT(in ) :: kjpt ! number of tracers 84 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,kjpt ) :: pgtu, pgtv ! tracer gradient at pstep levels 85 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 86 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 87 !!* Local declarations 88 INTEGER :: ji, jj, jk, jn ! dummy loop indices 89 INTEGER :: iku, ikv ! temporary integers 90 REAL(wp) :: zbtr, ztra ! temporary scalars 91 91 REAL(wp), DIMENSION(jpi,jpj) :: & 92 zeeu, zeev, zbtr, & ! 2D workspace 93 zlt, zls 94 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 95 zsu, zsv ! 3D workspace 92 zeeu, zeev, zlt ! 2D workspace 96 93 !!---------------------------------------------------------------------- 97 94 … … 101 98 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 102 99 ENDIF 103 104 105 ! ! =============== 106 DO jk = 1, jpkm1 ! Horizontal slab 107 ! ! =============== 108 109 ! 0. Initialization of metric arrays (for z- or s-coordinates) 110 ! ---------------------------------- 111 112 IF( lk_zco ) THEN ! z-coordinate (1D arrays): no vertical scale factors 100 ! ! =========== 101 DO jn = 1, kjpt ! tracer loop 102 ! ! =========== 103 ! 104 DO jk = 1, jpkm1 105 ! 106 107 ! 0. Initialization of metric arrays (for z- or s-coordinates) 108 ! ---------------------------------- 113 109 DO jj = 1, jpjm1 114 110 DO ji = 1, fs_jpim1 ! vector opt. 115 zbtr(ji,jj) = 1. / ( e1t(ji,jj)*e2t(ji,jj) )116 zeeu(ji,jj) = e2u(ji,jj) / e1u(ji,jj) * umask(ji,jj,jk)117 zeev(ji,jj) = e1v(ji,jj) / e2v(ji,jj) * vmask(ji,jj,jk)118 END DO119 END DO120 ELSE ! All coordinates (3D arrays): vertical scale factor are used121 DO jj = 1, jpjm1122 DO ji = 1, fs_jpim1 ! vector opt.123 zbtr(ji,jj) = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) )124 111 zeeu(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 125 112 zeev(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 126 113 END DO 127 114 END DO 128 ENDIF129 115 130 116 131 ! 1. Laplacian 132 ! ------------ 133 134 ! First derivative (gradient) 135 DO jj = 1, jpjm1 136 DO ji = 1, fs_jpim1 ! vector opt. 137 ztu(ji,jj,jk) = zeeu(ji,jj) * ( tb(ji+1,jj ,jk) - tb(ji,jj,jk) ) 138 zsu(ji,jj,jk) = zeeu(ji,jj) * ( sb(ji+1,jj ,jk) - sb(ji,jj,jk) ) 139 ztv(ji,jj,jk) = zeev(ji,jj) * ( tb(ji ,jj+1,jk) - tb(ji,jj,jk) ) 140 zsv(ji,jj,jk) = zeev(ji,jj) * ( sb(ji ,jj+1,jk) - sb(ji,jj,jk) ) 141 END DO 142 END DO 143 IF( ln_zps ) THEN ! set gradient at partial step level 117 ! 1. Laplacian 118 ! ------------ 119 120 ! First derivative (gradient) 144 121 DO jj = 1, jpjm1 145 DO ji = 1, jpim1 146 ! last level 147 iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1 148 ikv = MIN ( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1 149 IF( iku == jk ) THEN 150 ztu(ji,jj,jk) = zeeu(ji,jj) * gtu(ji,jj) 151 zsu(ji,jj,jk) = zeeu(ji,jj) * gsu(ji,jj) 152 ENDIF 153 IF( ikv == jk ) THEN 154 ztv(ji,jj,jk) = zeev(ji,jj) * gtv(ji,jj) 155 zsv(ji,jj,jk) = zeev(ji,jj) * gsv(ji,jj) 156 ENDIF 122 DO ji = 1, fs_jpim1 ! vector opt. 123 ztu(ji,jj,jk) = zeeu(ji,jj) * ( ptrab(ji+1,jj ,jk,jn) - ptrab(ji,jj,jk,jn) ) 124 ztv(ji,jj,jk) = zeev(ji,jj) * ( ptrab(ji ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 157 125 END DO 158 126 END DO 159 ENDIF 160 161 ! Second derivative (divergence) 162 DO jj = 2, jpjm1 163 DO ji = fs_2, fs_jpim1 ! vector opt. 164 zlt(ji,jj) = zbtr(ji,jj) * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 165 zls(ji,jj) = zbtr(ji,jj) * ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) + zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) 166 END DO 167 END DO 168 169 ! Multiply by the eddy diffusivity coefficient 170 DO jj = 2, jpjm1 171 DO ji = fs_2, fs_jpim1 ! vector opt. 172 zlt(ji,jj) = fsahtt(ji,jj,jk) * zlt(ji,jj) 173 zls(ji,jj) = fsahtt(ji,jj,jk) * zls(ji,jj) 174 END DO 175 END DO 176 177 ! Lateral boundary conditions on the laplacian (zlt,zls) (unchanged sgn) 178 CALL lbc_lnk( zlt, 'T', 1. ) ; CALL lbc_lnk( zls, 'T', 1. ) 179 180 ! 2. Bilaplacian 181 ! -------------- 182 183 ! third derivative (gradient) 184 DO jj = 1, jpjm1 185 DO ji = 1, fs_jpim1 ! vector opt. 186 ztu(ji,jj,jk) = zeeu(ji,jj) * ( zlt(ji+1,jj ) - zlt(ji,jj) ) 187 zsu(ji,jj,jk) = zeeu(ji,jj) * ( zls(ji+1,jj ) - zls(ji,jj) ) 188 ztv(ji,jj,jk) = zeev(ji,jj) * ( zlt(ji ,jj+1) - zlt(ji,jj) ) 189 zsv(ji,jj,jk) = zeev(ji,jj) * ( zls(ji ,jj+1) - zls(ji,jj) ) 190 END DO 191 END DO 192 193 ! fourth derivative (divergence) and add to the general tracer trend 194 DO jj = 2, jpjm1 195 DO ji = fs_2, fs_jpim1 ! vector opt. 196 ! horizontal diffusive trends 197 zta = zbtr(ji,jj) * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 198 zsa = zbtr(ji,jj) * ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) + zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) 199 ! add it to the general tracer trends 200 ta(ji,jj,jk) = ta(ji,jj,jk) + zta 201 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 202 END DO 203 END DO 204 ! ! =============== 205 END DO ! Horizontal slab 206 ! ! =============== 207 208 ! "zonal" mean lateral diffusive heat and salt transport 209 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 210 IF( lk_zco ) THEN ! z-coordinate (1D arrays): multiply by the vertical scale factor 211 DO jk = 1, jpkm1 212 DO jj = 2, jpjm1 213 DO ji = fs_2, fs_jpim1 ! vector opt. 214 ztv(ji,jj,jk) = ztv(ji,jj,jk) * fse3v(ji,jj,jk) 215 zsv(ji,jj,jk) = zsv(ji,jj,jk) * fse3v(ji,jj,jk) 127 IF( ln_zps ) THEN ! set gradient at partial step level 128 DO jj = 1, jpjm1 129 DO ji = 1, jpim1 130 ! last level 131 iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1 132 ikv = MIN ( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1 133 IF( iku == jk ) ztu(ji,jj,jk) = zeeu(ji,jj) * pgtu(ji,jj,jn) 134 IF( ikv == jk ) ztv(ji,jj,jk) = zeev(ji,jj) * pgtv(ji,jj,jn) 216 135 END DO 217 136 END DO 137 ENDIF 138 139 ! Second derivative (divergence) multiply by the eddy diffusivity coefficient 140 DO jj = 2, jpjm1 141 DO ji = fs_2, fs_jpim1 ! vector opt. 142 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 143 zlt(ji,jj) = fsahtt(ji,jj,jk) & 144 & * zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 145 END DO 218 146 END DO 147 148 ! Lateral boundary conditions on the laplacian (zlt) (unchanged sgn) 149 CALL lbc_lnk( zlt, 'T', 1. ) 150 151 ! 2. Bilaplacian 152 ! -------------- 153 154 ! third derivative (gradient) 155 DO jj = 1, jpjm1 156 DO ji = 1, fs_jpim1 ! vector opt. 157 ztu(ji,jj,jk) = zeeu(ji,jj) * ( zlt(ji+1,jj ) - zlt(ji,jj) ) 158 ztv(ji,jj,jk) = zeev(ji,jj) * ( zlt(ji ,jj+1) - zlt(ji,jj) ) 159 END DO 160 END DO 161 162 ! fourth derivative (divergence) and add to the general tracer trend 163 DO jj = 2, jpjm1 164 DO ji = fs_2, fs_jpim1 ! vector opt. 165 ! horizontal diffusive trends 166 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 167 ztra = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 168 ! add it to the general tracer trends 169 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 170 END DO 171 END DO 172 ! ! =============== 173 END DO ! Horizontal slab 174 ! ! =============== 175 ! "zonal" mean lateral diffusive heat and salt transport 176 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 177 IF( jn == jp_tem ) pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 178 IF( jn == jp_sal ) pst_ldf(:) = ptr_vj( ztv(:,:,:) ) 219 179 ENDIF 220 pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 221 pst_ldf(:) = ptr_vj( zsv(:,:,:) ) 222 ENDIF 180 ! 181 END DO 223 182 224 183 END SUBROUTINE tra_ldf_bilap -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_bilapg.F90
r1152 r2024 2 2 !!============================================================================== 3 3 !! *** MODULE traldf_bilapg *** 4 !! Ocean active tracers: horizontal component of the lateral tracer mixing trend 4 !! Ocean tracers: horizontal component of the lateral tracer mixing trend 5 !!============================================================================== 6 !! History : 8.0 ! 1997-07 (G. Madec) Original code 7 !! NEMO ! 2002-08 (G. Madec) F90: Free form and module 8 !! 3.3 ! 2010-06 (C. Ethe, G. Madec) Merge TRA-TRC 5 9 !!============================================================================== 6 10 #if defined key_ldfslp || defined key_esopa … … 16 20 USE dom_oce ! ocean space and time domain variables 17 21 USE ldftra_oce ! ocean active tracers: lateral physics 18 USE trdmod ! ocean active tracers trends19 USE trdmod_oce ! ocean variables trends20 22 USE in_out_manager ! I/O manager 21 23 USE ldfslp ! iso-neutral slopes available 22 24 USE lbclnk ! ocean lateral boundary condition (or mpp link) 23 25 USE diaptr ! poleward transport diagnostics 24 USE prtctl ! Print control25 26 26 27 IMPLICIT NONE … … 42 43 CONTAINS 43 44 44 SUBROUTINE tra_ldf_bilapg( kt )45 SUBROUTINE tra_ldf_bilapg( kt, cdtype, ptrab, ptraa, kjpt ) 45 46 !!---------------------------------------------------------------------- 46 47 !! *** ROUTINE tra_ldf_bilapg *** 47 48 !! 48 !! ** Purpose : Compute the before horizontal tracer (t & s)diffusive49 !! ** Purpose : Compute the before horizontal tracer diffusive 49 50 !! trend and add it to the general trend of tracer equation. 50 51 !! … … 54 55 !! computed in routine inildf. 55 56 !! -1- compute the geopotential harmonic operator applied to 56 !! (tb,sb)and multiply it by the eddy diffusivity coefficient57 !! (done by a call to ldfght routine, result in (wk1,wk2)arrays).57 !! ptrab and multiply it by the eddy diffusivity coefficient 58 !! (done by a call to ldfght routine, result in wk1 arrays). 58 59 !! Applied the domain lateral boundary conditions by call to lbc_lnk 59 60 !! -2- compute the geopotential harmonic operator applied to 60 !! (wk1,wk2) by a second call to ldfght routine (result in (wk3,wk4)61 !! wk1 by a second call to ldfght routine (result in wk2) 61 62 !! arrays). 62 !! -3- Add this trend to the general trend (ta,sa):63 !! (ta,sa) = (ta,sa) + (wk3,wk4)64 !! 65 !! ** Action : - Update (ta,sa)arrays with the before geopotential63 !! -3- Add this trend to the general trend 64 !! ptraa = ptraa + wk2 65 !! 66 !! ** Action : - Update ptraa arrays with the before geopotential 66 67 !! biharmonic mixing trend. 67 !! 68 !! History : 69 !! 8.0 ! 97-07 (G. Madec) Original code 70 !! 8.5 ! 02-08 (G. Madec) F90: Free form and module 71 !! 9.0 ! 04-08 (C. Talandier) New trends organization 72 !!---------------------------------------------------------------------- 73 !! * Modules used 74 USE oce , wk1 => ua, & ! use ua as workspace 75 & wk2 => va ! use va as workspace 76 77 !! * Arguments 78 INTEGER, INTENT( in ) :: kt ! ocean time-step index 79 68 !!---------------------------------------------------------------------- 69 !!* Arguments 70 INTEGER , INTENT(in ) :: kt ! ocean time-step index 71 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 72 INTEGER , INTENT(in ) :: kjpt ! number of tracers 73 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 74 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 80 75 !! * Local declarations 81 INTEGER :: ji, jj, jk ! dummy loop indices82 REAL(wp), DIMENSION(jpi,jpj,jpk ) :: &83 wk 3, wk4! work array used for rotated biharmonic76 INTEGER :: ji, jj, jk, jn ! dummy loop indices 77 REAL(wp), DIMENSION(jpi,jpj,jpk,SIZE(ptrab,4)) :: & 78 wk1, wk2 ! work array used for rotated biharmonic 84 79 ! ! operator on tracers and/or momentum 85 80 !!---------------------------------------------------------------------- … … 90 85 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 91 86 ENDIF 92 93 ! 1. Laplacian of (tb,sb) * aht 87 ! 88 ! 89 90 ! 1. Laplacian of ptrab * aht 94 91 ! ----------------------------- 95 ! rotated harmonic operator applied to (tb,sb) 96 ! and multiply by aht (output in (wk1,wk2) ) 97 98 CALL ldfght ( kt, tb, sb, wk1, wk2, 1 ) 99 100 101 ! Lateral boundary conditions on (wk1,wk2) (unchanged sign) 102 CALL lbc_lnk( wk1, 'T', 1. ) ; CALL lbc_lnk( wk2, 'T', 1. ) 103 104 ! 2. Bilaplacian of (tb,sb) 92 ! rotated harmonic operator applied to ptrab and multiply by aht ; output in wk1 93 94 CALL ldfght( kt, cdtype, ptrab, wk1, kjpt, 1 ) 95 96 ! 97 DO jn = 1, kjpt 98 ! Lateral boundary conditions on wk1 (unchanged sign) 99 CALL lbc_lnk( wk1(:,:,:,jn) , 'T', 1. ) 100 END DO 101 102 ! 2. Bilaplacian of ptrab 105 103 ! ------------------------- 106 ! rotated harmonic operator applied to (wk1,wk2) 107 ! (output in (wk3,wk4) ) 108 109 CALL ldfght ( kt, wk1, wk2, wk3, wk4, 2 ) 104 ! rotated harmonic operator applied to wk1 ; output in wk2 105 106 CALL ldfght( kt, cdtype, wk1, wk2, kjpt, 2 ) 110 107 111 108 112 109 ! 3. Update the tracer trends (j-slab : 2, jpj-1) 113 110 ! --------------------------- 114 ! ! =============== 115 DO jj = 2, jpjm1 ! Vertical slab 116 ! ! =============== 117 DO jk = 1, jpkm1 118 DO ji = 2, jpim1 119 ! add it to the general tracer trends 120 ta(ji,jj,jk) = ta(ji,jj,jk) + wk3(ji,jj,jk) 121 sa(ji,jj,jk) = sa(ji,jj,jk) + wk4(ji,jj,jk) 122 END DO 123 END DO 124 ! ! =============== 125 END DO ! End of slab 126 ! ! =============== 111 ! 112 DO jn = 1, kjpt 113 ! ! =============== 114 DO jj = 2, jpjm1 ! Vertical slab 115 ! ! =============== 116 DO jk = 1, jpkm1 117 DO ji = 2, jpim1 118 ! add it to the general tracer trends 119 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + wk2(ji,jj,jk,jn) 120 END DO 121 END DO 122 ! ! =============== 123 END DO ! End of slab 124 ! ! =============== 125 END DO 127 126 128 127 END SUBROUTINE tra_ldf_bilapg 129 128 130 129 131 SUBROUTINE ldfght ( kt, pt, ps, plt, pls, kaht )130 SUBROUTINE ldfght ( kt, cdtype, pt, plt, kjpt, kaht ) 132 131 !!---------------------------------------------------------------------- 133 132 !! *** ROUTINE ldfght *** 134 133 !! 135 !! ** Purpose : Apply a geopotential harmonic operator to (pt ,ps) and134 !! ** Purpose : Apply a geopotential harmonic operator to (pt) and 136 135 !! multiply it by the eddy diffusivity coefficient (if kaht=1). 137 136 !! Routine only used in s-coordinates (l_sco=T) with bilaplacian … … 140 139 !! 141 140 !! ** Method : The harmonic operator rotated along geopotential 142 !! surfaces is applied to (pt ,ps) using the slopes of geopotential141 !! surfaces is applied to (pt) using the slopes of geopotential 143 142 !! surfaces computed in inildf routine. The result is provided in 144 143 !! (plt,pls) arrays. It is computed in 2 steps: … … 166 165 !! plt = 1 / (e1t*e2t*e3t) { plt + dk[ zftw ] } 167 166 !! 168 !! * Action : 169 !! 'key_trdtra' defined: the trend is saved for diagnostics. 170 !! 171 !! History : 172 !! 8.0 ! 97-07 (G. Madec) Original code 173 !! 8.5 ! 02-08 (G. Madec) F90: Free form and module 174 !!---------------------------------------------------------------------- 167 !!---------------------------------------------------------------------- 168 !! * Modules used 169 USE oce , zftv => ua ! use ua as workspace 175 170 !! * Arguments 176 INTEGER, INTENT( in ) :: kt ! ocean time-step index 177 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: & 178 pt, ps ! tracer fields (before t and s for 1st call 179 ! ! and laplacian of these fields for 2nd call. 180 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) :: & 181 plt, pls ! partial harmonic operator applied to 182 ! ! pt & ps components except 183 ! ! second order vertical derivative term) 184 INTEGER, INTENT( in ) :: & 185 kaht ! =1 multiply the laplacian by the eddy diffusivity coeff. 186 ! ! =2 no multiplication 187 171 INTEGER , INTENT(in ) :: kt ! ocean time-step index 172 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 173 INTEGER , INTENT(in ) :: kjpt !: dimension of 174 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: pt ! tracer fields ( before for 1st call 175 ! ! and laplacian of these fields for 2nd call. 176 REAL(wp) , INTENT(out), DIMENSION(jpi,jpj,jpk,kjpt) :: plt !: partial harmonic operator applied to pt components except 177 ! !: second order vertical derivative term 178 INTEGER , INTENT(in ) :: kaht !: =1 multiply the laplacian by the eddy diffusivity coeff. 179 ! !: =2 no multiplication 188 180 !! * Local declarations 189 INTEGER :: ji, jj, jk ! dummy loop indices 190 REAL(wp) :: & 191 zabe1, zabe2, zmku, zmkv, & ! temporary scalars 192 zbtr, ztah, zsah, ztav, zsav, & 193 zcof0, zcof1, zcof2, & 194 zcof3, zcof4 195 REAL(wp), DIMENSION(jpi,jpj) :: & 196 zftu, zfsu, & ! workspace 197 zdkt, zdk1t, & 198 zdks, zdk1s 199 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 200 zftv, zfsv ! workspace (only v components for ptr) 201 REAL(wp), DIMENSION(jpi,jpk) :: & 202 zftw, zfsw, & ! workspace 203 zdit, zdjt, zdj1t, & 204 zdis, zdjs, zdj1s 205 !!---------------------------------------------------------------------- 206 207 ! ! ********** ! ! =============== 208 DO jk = 1, jpkm1 ! First step ! ! Horizontal slab 209 ! ! ********** ! ! =============== 210 211 ! I.1 Vertical gradient of pt and ps at level jk and jk+1 212 ! ------------------------------------------------------- 213 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 214 215 zdk1t(:,:) = ( pt(:,:,jk) - pt(:,:,jk+1) ) * tmask(:,:,jk+1) 216 zdk1s(:,:) = ( ps(:,:,jk) - ps(:,:,jk+1) ) * tmask(:,:,jk+1) 217 218 IF( jk == 1 ) THEN 219 zdkt(:,:) = zdk1t(:,:) 220 zdks(:,:) = zdk1s(:,:) 221 ELSE 222 zdkt(:,:) = ( pt(:,:,jk-1) - pt(:,:,jk) ) * tmask(:,:,jk) 223 zdks(:,:) = ( ps(:,:,jk-1) - ps(:,:,jk) ) * tmask(:,:,jk) 181 INTEGER :: ji, jj, jk,jn ! dummy loop indices 182 ! ! temporary scalars 183 REAL(wp) :: zabe1, zabe2, zmku, zmkv 184 REAL(wp) :: zbtr, ztah, ztav 185 REAL(wp) :: zcof0, zcof1, zcof2, zcof3, zcof4 186 REAL(wp), DIMENSION(jpi,jpj) :: zftu, zdkt, zdk1t ! workspace 187 REAL(wp), DIMENSION(jpi,jpk) :: zftw, zdit, zdjt, zdj1t ! 188 !!---------------------------------------------------------------------- 189 190 ! 191 DO jn = 1, kjpt 192 ! ! ********** ! ! =============== 193 DO jk = 1, jpkm1 ! First step ! ! Horizontal slab 194 ! ! ********** ! ! =============== 195 196 ! I.1 Vertical gradient of pt and ps at level jk and jk+1 197 ! ------------------------------------------------------- 198 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 199 200 zdk1t(:,:) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 201 IF( jk == 1 ) THEN 202 zdkt(:,:) = zdk1t(:,:) 203 ELSE 204 zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * tmask(:,:,jk) 205 ENDIF 206 207 208 ! I.2 Horizontal fluxes 209 ! --------------------- 210 211 DO jj = 1, jpjm1 212 DO ji = 1, jpim1 213 zabe1 = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 214 zabe2 = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 215 216 zmku = 1./MAX( tmask(ji+1,jj,jk )+tmask(ji,jj,jk+1) & 217 & +tmask(ji+1,jj,jk+1)+tmask(ji,jj,jk ),1. ) 218 zmkv = 1./MAX( tmask(ji,jj+1,jk )+tmask(ji,jj,jk+1) & 219 & +tmask(ji,jj+1,jk+1)+tmask(ji,jj,jk ),1. ) 220 221 zcof1 = -e2u(ji,jj) * uslp(ji,jj,jk) * zmku 222 zcof2 = -e1v(ji,jj) * vslp(ji,jj,jk) * zmkv 223 224 zftu(ji,jj)= umask(ji,jj,jk) * & 225 & ( zabe1 *( pt (ji+1,jj,jk,jn) - pt(ji,jj,jk,jn) ) & 226 & + zcof1 *( zdkt (ji+1,jj) + zdk1t(ji,jj) & 227 & +zdk1t(ji+1,jj) + zdkt (ji,jj) ) ) 228 229 zftv(ji,jj,jk)= vmask(ji,jj,jk) * & 230 & ( zabe2 *( pt(ji,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) & 231 & + zcof2 *( zdkt (ji,jj+1) + zdk1t(ji,jj) & 232 & +zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) 233 END DO 234 END DO 235 236 237 ! I.3 Second derivative (divergence) (not divided by the volume) 238 ! --------------------- 239 240 DO jj = 2 , jpjm1 241 DO ji = 2 , jpim1 242 ztah = zftu(ji,jj) - zftu(ji-1,jj) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) 243 plt(ji,jj,jk,jn) = ztah 244 END DO 245 END DO 246 ! ! =============== 247 END DO ! End of slab 248 ! ! =============== 249 ! "Poleward" diffusive heat or salt transport 250 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 251 IF( jn == jp_tem) pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 252 IF( jn == jp_sal) pst_ldf(:) = ptr_vj( zftv(:,:,:) ) 224 253 ENDIF 225 254 226 227 ! I.2 Horizontal fluxes 228 ! --------------------- 229 230 DO jj = 1, jpjm1 231 DO ji = 1, jpim1 232 zabe1 = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 233 zabe2 = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 234 235 zmku=1./MAX( tmask(ji+1,jj,jk )+tmask(ji,jj,jk+1) & 236 +tmask(ji+1,jj,jk+1)+tmask(ji,jj,jk ),1. ) 237 zmkv=1./MAX( tmask(ji,jj+1,jk )+tmask(ji,jj,jk+1) & 238 +tmask(ji,jj+1,jk+1)+tmask(ji,jj,jk ),1. ) 239 240 zcof1= -e2u(ji,jj) * uslp(ji,jj,jk) * zmku 241 zcof2= -e1v(ji,jj) * vslp(ji,jj,jk) * zmkv 242 243 zftu(ji,jj)= umask(ji,jj,jk) * & 244 ( zabe1 *( pt(ji+1,jj,jk) - pt(ji,jj,jk) ) & 245 + zcof1 *( zdkt (ji+1,jj) + zdk1t(ji,jj) & 246 +zdk1t(ji+1,jj) + zdkt (ji,jj) ) ) 247 248 zftv(ji,jj,jk)= vmask(ji,jj,jk) * & 249 ( zabe2 *( pt(ji,jj+1,jk) - pt(ji,jj,jk) ) & 250 + zcof2 *( zdkt (ji,jj+1) + zdk1t(ji,jj) & 251 +zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) 252 253 zfsu(ji,jj)= umask(ji,jj,jk) * & 254 ( zabe1 *( ps(ji+1,jj,jk) - ps(ji,jj,jk) ) & 255 + zcof1 *( zdks (ji+1,jj) + zdk1s(ji,jj) & 256 +zdk1s(ji+1,jj) + zdks (ji,jj) ) ) 257 258 zfsv(ji,jj,jk)= vmask(ji,jj,jk) * & 259 ( zabe2 *( ps(ji,jj+1,jk) - ps(ji,jj,jk) ) & 260 + zcof2 *( zdks (ji,jj+1) + zdk1s(ji,jj) & 261 +zdk1s(ji,jj+1) + zdks (ji,jj) ) ) 262 END DO 263 END DO 264 265 266 ! I.3 Second derivative (divergence) (not divided by the volume) 267 ! --------------------- 268 269 DO jj = 2 , jpjm1 270 DO ji = 2 , jpim1 271 ztah = zftu(ji,jj) - zftu(ji-1,jj) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) 272 zsah = zfsu(ji,jj) - zfsu(ji-1,jj) + zfsv(ji,jj,jk) - zfsv(ji,jj-1,jk) 273 plt(ji,jj,jk) = ztah 274 pls(ji,jj,jk) = zsah 275 END DO 276 END DO 277 ! ! =============== 278 END DO ! End of slab 279 ! ! =============== 280 281 !!but this should be done somewhere after 282 ! "zonal" mean diffusive heat and salt transport 283 IF( ln_diaptr .AND. ( kaht == 2 ) .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 284 pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 285 pst_ldf(:) = ptr_vj( zfsv(:,:,:) ) 286 ENDIF 287 288 ! ! ************ ! ! =============== 289 DO jj = 2, jpjm1 ! Second step ! ! Horizontal slab 290 ! ! ************ ! ! =============== 291 292 ! II.1 horizontal tracer gradient 293 ! ------------------------------- 294 295 DO jk = 1, jpk 296 DO ji = 1, jpim1 297 zdit (ji,jk) = ( pt(ji+1,jj ,jk) - pt(ji,jj ,jk) ) * umask(ji,jj ,jk) 298 zdis (ji,jk) = ( ps(ji+1,jj ,jk) - ps(ji,jj ,jk) ) * umask(ji,jj ,jk) 299 zdjt (ji,jk) = ( pt(ji ,jj+1,jk) - pt(ji,jj ,jk) ) * vmask(ji,jj ,jk) 300 zdjs (ji,jk) = ( ps(ji ,jj+1,jk) - ps(ji,jj ,jk) ) * vmask(ji,jj ,jk) 301 zdj1t(ji,jk) = ( pt(ji ,jj ,jk) - pt(ji,jj-1,jk) ) * vmask(ji,jj-1,jk) 302 zdj1s(ji,jk) = ( ps(ji ,jj ,jk) - ps(ji,jj-1,jk) ) * vmask(ji,jj-1,jk) 303 END DO 304 END DO 305 306 307 ! II.2 Vertical fluxes 308 ! -------------------- 309 310 ! Surface and bottom vertical fluxes set to zero 311 zftw(:, 1 ) = 0.e0 312 zfsw(:, 1 ) = 0.e0 313 zftw(:,jpk) = 0.e0 314 zfsw(:,jpk) = 0.e0 315 316 ! interior (2=<jk=<jpk-1) 317 DO jk = 2, jpkm1 318 DO ji = 2, jpim1 319 zcof0 = e1t(ji,jj) * e2t(ji,jj) / fse3w(ji,jj,jk) & 320 * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & 321 + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) 322 323 zmku =1./MAX( umask(ji ,jj,jk-1)+umask(ji-1,jj,jk) & 324 +umask(ji-1,jj,jk-1)+umask(ji ,jj,jk), 1. ) 325 326 zmkv =1./MAX( vmask(ji,jj ,jk-1)+vmask(ji,jj-1,jk) & 327 +vmask(ji,jj-1,jk-1)+vmask(ji,jj ,jk), 1. ) 328 329 zcof3 = - e2t(ji,jj) * wslpi (ji,jj,jk) * zmku 330 zcof4 = - e1t(ji,jj) * wslpj (ji,jj,jk) * zmkv 331 332 zftw(ji,jk) = tmask(ji,jj,jk) * & 333 ( zcof0 * ( pt (ji,jj,jk-1) - pt (ji,jj,jk) ) & 334 + zcof3 * ( zdit (ji ,jk-1) + zdit (ji-1,jk) & 335 +zdit (ji-1,jk-1) + zdit (ji ,jk) ) & 336 + zcof4 * ( zdjt (ji ,jk-1) + zdj1t(ji ,jk) & 337 +zdj1t(ji ,jk-1) + zdjt (ji ,jk) ) ) 338 339 zfsw(ji,jk) = tmask(ji,jj,jk) * & 340 ( zcof0 * ( ps (ji,jj,jk-1) - ps (ji,jj,jk) ) & 341 + zcof3 * ( zdis (ji ,jk-1) + zdis (ji-1,jk) & 342 +zdis (ji-1,jk-1) + zdis (ji ,jk) ) & 343 + zcof4 * ( zdjs (ji ,jk-1) + zdj1s(ji ,jk) & 344 +zdj1s(ji ,jk-1) + zdjs (ji ,jk) ) ) 345 END DO 346 END DO 347 348 349 ! II.3 Divergence of vertical fluxes added to the horizontal divergence 350 ! --------------------------------------------------------------------- 351 352 IF( kaht == 1 ) THEN 353 ! multiply the laplacian by the eddy diffusivity coefficient 354 DO jk = 1, jpkm1 255 ! ! ************ ! ! =============== 256 DO jj = 2, jpjm1 ! Second step ! ! Horizontal slab 257 ! ! ************ ! ! =============== 258 259 ! II.1 horizontal tracer gradient 260 ! ------------------------------- 261 262 DO jk = 1, jpk 263 DO ji = 1, jpim1 264 zdit (ji,jk) = ( pt(ji+1,jj ,jk,jn) - pt(ji,jj ,jk,jn) ) * umask(ji,jj ,jk) 265 zdjt (ji,jk) = ( pt(ji ,jj+1,jk,jn) - pt(ji,jj ,jk,jn) ) * vmask(ji,jj ,jk) 266 zdj1t(ji,jk) = ( pt(ji ,jj ,jk,jn) - pt(ji,jj-1,jk,jn) ) * vmask(ji,jj-1,jk) 267 END DO 268 END DO 269 270 271 ! II.2 Vertical fluxes 272 ! -------------------- 273 274 ! Surface and bottom vertical fluxes set to zero 275 zftw(:, 1 ) = 0.e0 276 zftw(:,jpk) = 0.e0 277 278 ! interior (2=<jk=<jpk-1) 279 DO jk = 2, jpkm1 355 280 DO ji = 2, jpim1 356 ! eddy coef. divided by the volume element 357 zbtr = fsahtt(ji,jj,jk) / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 358 ! vertical divergence 359 ztav = zftw(ji,jk) - zftw(ji,jk+1) 360 zsav = zfsw(ji,jk) - zfsw(ji,jk+1) 361 ! harmonic operator applied to (pt,ps) and multiply by aht 362 plt(ji,jj,jk) = ( plt(ji,jj,jk) + ztav ) * zbtr 363 pls(ji,jj,jk) = ( pls(ji,jj,jk) + zsav ) * zbtr 364 END DO 365 END DO 366 ELSEIF( kaht == 2 ) THEN 367 ! second call, no multiplication 368 DO jk = 1, jpkm1 369 DO ji = 2, jpim1 370 ! inverse of the volume element 371 zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 372 ! vertical divergence 373 ztav = zftw(ji,jk) - zftw(ji,jk+1) 374 zsav = zfsw(ji,jk) - zfsw(ji,jk+1) 375 ! harmonic operator applied to (pt,ps) 376 plt(ji,jj,jk) = ( plt(ji,jj,jk) + ztav ) * zbtr 377 pls(ji,jj,jk) = ( pls(ji,jj,jk) + zsav ) * zbtr 378 END DO 379 END DO 380 ELSE 381 IF(lwp) WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht 382 IF(lwp) WRITE(numout,*) ' We stop' 383 STOP 'ldfght' 384 ENDIF 385 ! ! =============== 386 END DO ! End of slab 387 ! ! =============== 281 zcof0 = e1t(ji,jj) * e2t(ji,jj) / fse3w(ji,jj,jk) & 282 & * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & 283 & + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) 284 285 zmku = 1./MAX( umask(ji ,jj,jk-1)+umask(ji-1,jj,jk) & 286 & +umask(ji-1,jj,jk-1)+umask(ji ,jj,jk), 1. ) 287 288 zmkv = 1./MAX( vmask(ji,jj ,jk-1)+vmask(ji,jj-1,jk) & 289 & +vmask(ji,jj-1,jk-1)+vmask(ji,jj ,jk), 1. ) 290 291 zcof3 = - e2t(ji,jj) * wslpi (ji,jj,jk) * zmku 292 zcof4 = - e1t(ji,jj) * wslpj (ji,jj,jk) * zmkv 293 294 zftw(ji,jk) = tmask(ji,jj,jk) * & 295 & ( zcof0 * ( pt (ji,jj,jk-1,jn) - pt (ji ,jj,jk,jn) ) & 296 & + zcof3 * ( zdit (ji ,jk-1 ) + zdit (ji-1,jk ) & 297 & +zdit (ji-1 ,jk-1 ) + zdit (ji ,jk ) ) & 298 & + zcof4 * ( zdjt (ji ,jk-1 ) + zdj1t(ji ,jk) & 299 & +zdj1t(ji ,jk-1 ) + zdjt (ji ,jk ) ) ) 300 END DO 301 END DO 302 303 304 ! II.3 Divergence of vertical fluxes added to the horizontal divergence 305 ! --------------------------------------------------------------------- 306 307 IF( kaht == 1 ) THEN 308 ! multiply the laplacian by the eddy diffusivity coefficient 309 DO jk = 1, jpkm1 310 DO ji = 2, jpim1 311 ! eddy coef. divided by the volume element 312 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 313 ! vertical divergence 314 ztav = fsahtt(ji,jj,jk) * ( zftw(ji,jk) - zftw(ji,jk+1) ) 315 ! harmonic operator applied to (pt,ps) and multiply by aht 316 plt(ji,jj,jk,jn) = ( plt(ji,jj,jk,jn) + ztav ) * zbtr 317 END DO 318 END DO 319 ELSEIF( kaht == 2 ) THEN 320 ! second call, no multiplication 321 DO jk = 1, jpkm1 322 DO ji = 2, jpim1 323 ! inverse of the volume element 324 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 325 ! vertical divergence 326 ztav = zftw(ji,jk) - zftw(ji,jk+1) 327 ! harmonic operator applied to (pt,ps) 328 plt(ji,jj,jk,jn) = ( plt(ji,jj,jk,jn) + ztav ) * zbtr 329 END DO 330 END DO 331 ELSE 332 IF(lwp) WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht 333 IF(lwp) WRITE(numout,*) ' We stop' 334 STOP 'ldfght' 335 ENDIF 336 ! ! =============== 337 END DO ! End of slab 338 ! ! =============== 339 END DO 340 ! 388 341 END SUBROUTINE ldfght 389 342 -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_iso.F90
r1756 r2024 2 2 !!====================================================================== 3 3 !! *** MODULE traldf_iso *** 4 !! Ocean activetracers: horizontal component of the lateral tracer mixing trend4 !! Ocean tracers: horizontal component of the lateral tracer mixing trend 5 5 !!====================================================================== 6 !! History : ! 94-08 (G. Madec, M. Imbard) 7 !! ! 97-05 (G. Madec) split into traldf and trazdf 8 !! 8.5 ! 02-08 (G. Madec) Free form, F90 9 !! 9.0 ! 05-11 (G. Madec) merge traldf and trazdf :-) 6 !! History : OPA ! 1994-08 (G. Madec, M. Imbard) 7 !! ! 1997-05 (G. Madec) split into traldf and trazdf 8 !! NEMO ! 2002-08 (G. Madec) Free form, F90 9 !! 1.0 ! 2005-11 (G. Madec) merge traldf and trazdf :-) 10 !! 3.0 ! 2008-01 (C. Ethe, G. Madec) Merge TRA-TRC 10 11 !!---------------------------------------------------------------------- 11 12 #if defined key_ldfslp || defined key_esopa … … 22 23 USE dom_oce ! ocean space and time domain 23 24 USE ldftra_oce ! ocean active tracers: lateral physics 24 USE trdmod ! ocean active tracers trends25 USE trdmod_oce ! ocean variables trends26 25 USE zdf_oce ! ocean vertical physics 27 26 USE in_out_manager ! I/O manager … … 29 28 USE ldfslp ! iso-neutral slopes 30 29 USE diaptr ! poleward transport diagnostics 31 USE prtctl ! Print control32 30 #if defined key_diaar5 33 31 USE phycst ! physical constants … … 52 50 CONTAINS 53 51 54 SUBROUTINE tra_ldf_iso( kt ) 52 SUBROUTINE tra_ldf_iso( kt , cdtype, pgtu, pgtv, & 53 & ptrab, ptraa , kjpt, pahtb0 ) 55 54 !!---------------------------------------------------------------------- 56 55 !! *** ROUTINE tra_ldf_iso *** … … 66 65 !! nal or geopotential slopes computed in routine ldfslp. 67 66 !! 68 !! 1st part : masked horizontal derivative of T & S( di[ t ] )67 !! 1st part : masked horizontal derivative of T ( di[ t ] ) 69 68 !! ======== with partial cell update if ln_zps=T. 70 69 !! … … 88 87 !! difft = 1/(e1t*e2t*e3t) dk[ zftw ] 89 88 !! Add this trend to the general trend (ta,sa): 90 !! ta = ta + difft 91 !! 92 !! ** Action : Update (ta,sa) arrays with the before rotated diffusion 93 !! trend (except the dk[ dk[.] ] term) 89 !! pta = pta + difft 90 !! 91 !! ** Action : Update pta arrays with the before rotated diffusion 94 92 !!---------------------------------------------------------------------- 95 USE oce , zftv => ua ! use ua as workspace 96 USE oce , zfsv => va ! use va as workspace 97 !! 98 INTEGER, INTENT( in ) :: kt ! ocean time-step index 99 !! 100 INTEGER :: ji, jj, jk ! dummy loop indices 101 INTEGER :: iku, ikv ! temporary integer 102 REAL(wp) :: zmsku, zabe1, zcof1, zcoef3, zta ! temporary scalars 103 REAL(wp) :: zmskv, zabe2, zcof2, zcoef4, zsa ! " " 104 REAL(wp) :: zcoef0, zbtr ! " " 105 REAL(wp), DIMENSION(jpi,jpj) :: zdkt , zdk1t ! 2D workspace 106 REAL(wp), DIMENSION(jpi,jpj) :: zdks , zdk1s, zfsu ! " " 93 !!* Module used 94 USE oce , zftu => ua ! use ua as workspace 95 USE oce , zftv => va ! use va as workspace 96 !!* Arguments 97 INTEGER , INTENT(in ) :: kt ! ocean time-step index 98 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 99 INTEGER , INTENT(in ) :: kjpt ! number of tracers 100 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,kjpt ) :: pgtu, pgtv ! tracer gradient at pstep levels 101 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 102 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 103 REAL(wp) , INTENT(in ) :: pahtb0 ! background diffusion coef 104 !!* Local declarations 105 INTEGER :: ji, jj, jk,jn ! dummy loop indices 106 INTEGER :: iku, ikv ! temporary integer 107 REAL(wp) :: zmsku, zabe1, zcof1, zcoef3 ! temporary scalars 108 REAL(wp) :: zmskv, zabe2, zcof2, zcoef4 ! " " 109 REAL(wp) :: zcoef0, zbtr, ztra ! " " 110 REAL(wp), DIMENSION(jpi,jpj) :: zdkt, zdk1t ! 2D workspace 111 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, ztfw ! 3D workspace 107 112 #if defined key_diaar5 108 113 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! " " 109 114 REAL(wp) :: zztmp ! " " 110 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zftu ! 3D workspace111 #else112 REAL(wp), DIMENSION(jpi,jpj) :: zftu ! 2D workspace113 115 #endif 114 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, ztfw ! 3D workspace115 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdis, zdjs, zsfw ! " "116 # if defined key_diaar5117 # endif118 116 !!---------------------------------------------------------------------- 119 117 … … 123 121 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 124 122 ENDIF 125 126 !!---------------------------------------------------------------------- 127 !! I - masked horizontal derivative of T & S 128 !!---------------------------------------------------------------------- 129 !!bug ajout.... why? ( 1,jpj,:) and (jpi,1,:) should be sufficient.... 130 zdit (1,:,:) = 0.e0 ; zdit (jpi,:,:) = 0.e0 131 zdis (1,:,:) = 0.e0 ; zdis (jpi,:,:) = 0.e0 132 zdjt (1,:,:) = 0.e0 ; zdjt (jpi,:,:) = 0.e0 133 zdjs (1,:,:) = 0.e0 ; zdjs (jpi,:,:) = 0.e0 134 !!end 135 136 ! Horizontal temperature and salinity gradient 137 DO jk = 1, jpkm1 138 DO jj = 1, jpjm1 139 DO ji = 1, fs_jpim1 ! vector opt. 140 zdit(ji,jj,jk) = ( tb(ji+1,jj ,jk) - tb(ji,jj,jk) ) * umask(ji,jj,jk) 141 zdis(ji,jj,jk) = ( sb(ji+1,jj ,jk) - sb(ji,jj,jk) ) * umask(ji,jj,jk) 142 zdjt(ji,jj,jk) = ( tb(ji ,jj+1,jk) - tb(ji,jj,jk) ) * vmask(ji,jj,jk) 143 zdjs(ji,jj,jk) = ( sb(ji ,jj+1,jk) - sb(ji,jj,jk) ) * vmask(ji,jj,jk) 123 ! 124 ! ! =========== 125 DO jn = 1, kjpt ! tracer loop 126 ! ! =========== 127 ! 128 !!---------------------------------------------------------------------- 129 !! I - masked horizontal derivative 130 !!---------------------------------------------------------------------- 131 !!bug ajout.... why? ( 1,jpj,:) and (jpi,1,:) should be sufficient.... 132 zdit (1,:,:) = 0.e0 ; zdit (jpi,:,:) = 0.e0 133 zdjt (1,:,:) = 0.e0 ; zdjt (jpi,:,:) = 0.e0 134 !!end 135 136 ! Horizontal tracer gradient 137 DO jk = 1, jpkm1 138 DO jj = 1, jpjm1 139 DO ji = 1, fs_jpim1 ! vector opt. 140 zdit(ji,jj,jk) = ( ptrab(ji+1,jj ,jk,jn) - ptrab(ji,jj,jk,jn) ) * umask(ji,jj,jk) 141 zdjt(ji,jj,jk) = ( ptrab(ji ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 142 END DO 144 143 END DO 145 144 END DO 146 END DO 147 IF( ln_zps ) THEN ! partial steps correction at the last level 148 DO jj = 1, jpjm1 149 DO ji = 1, fs_jpim1 ! vector opt. 150 ! last level 151 iku = MIN( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1 152 ikv = MIN( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1 153 zdit(ji,jj,iku) = gtu(ji,jj) 154 zdis(ji,jj,iku) = gsu(ji,jj) 155 zdjt(ji,jj,ikv) = gtv(ji,jj) 156 zdjs(ji,jj,ikv) = gsv(ji,jj) 145 IF( ln_zps ) THEN ! partial steps correction at the last level 146 DO jj = 1, jpjm1 147 DO ji = 1, fs_jpim1 ! vector opt. 148 ! last level 149 iku = MIN( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1 150 ikv = MIN( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1 151 zdit(ji,jj,iku) = pgtu(ji,jj,jn) 152 zdjt(ji,jj,ikv) = pgtv(ji,jj,jn) 153 END DO 154 END DO 155 ENDIF 156 157 !!---------------------------------------------------------------------- 158 !! II - horizontal trend (full) 159 !!---------------------------------------------------------------------- 160 161 !CDIR PARALLEL DO PRIVATE( zdk1t ) 162 ! ! =============== 163 DO jk = 1, jpkm1 ! Horizontal slab 164 ! ! =============== 165 ! 1. Vertical tracer gradient at level jk and jk+1 166 ! ------------------------------------------------ 167 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 168 169 zdk1t(:,:) = ( ptrab(:,:,jk,jn) - ptrab(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 170 171 IF( jk == 1 ) THEN 172 zdkt(:,:) = zdk1t(:,:) 173 ELSE 174 zdkt(:,:) = ( ptrab(:,:,jk-1,jn) - ptrab(:,:,jk,jn) ) * tmask(:,:,jk) 175 ENDIF 176 177 178 ! 2. Horizontal fluxes 179 ! -------------------- 180 181 DO jj = 1 , jpjm1 182 DO ji = 1, fs_jpim1 ! vector opt. 183 zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 184 zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 185 186 zmsku = 1. / MAX( tmask(ji+1,jj,jk ) + tmask(ji,jj,jk+1) & 187 & + tmask(ji+1,jj,jk+1) + tmask(ji,jj,jk ), 1. ) 188 189 zmskv = 1. / MAX( tmask(ji,jj+1,jk ) + tmask(ji,jj,jk+1) & 190 & + tmask(ji,jj+1,jk+1) + tmask(ji,jj,jk ), 1. ) 191 192 zcof1 = - fsahtu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 193 zcof2 = - fsahtv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 194 ! 195 zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) & 196 & + zcof1 * ( zdkt (ji+1,jj) + zdk1t(ji,jj) & 197 & + zdk1t(ji+1,jj) + zdkt (ji,jj) ) ) * umask(ji,jj,jk) 198 zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & 199 & + zcof2 * ( zdkt (ji,jj+1) + zdk1t(ji,jj) & 200 & + zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) * vmask(ji,jj,jk) 201 END DO 202 END DO 203 204 205 ! II.4 Second derivative (divergence) and add to the general trend 206 ! ---------------------------------------------------------------- 207 DO jj = 2 , jpjm1 208 DO ji = fs_2, fs_jpim1 ! vector opt. 209 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 210 ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 211 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 212 END DO 213 END DO 214 ! ! =============== 215 END DO ! End of slab 216 ! ! =============== 217 ! "Poleward" diffusive heat or salt transports 218 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 219 IF( jn == jp_tem) pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 220 IF( jn == jp_sal) pst_ldf(:) = ptr_vj( zftv(:,:,:) ) 221 ENDIF 222 223 #if defined key_diaar5 224 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 225 zztmp = 0.5 * rau0 * rcp 226 z2d(:,:) = 0.e0 227 DO jk = 1, jpkm1 228 DO jj = 2, jpjm1 229 DO ji = fs_2, fs_jpim1 ! vector opt. 230 z2d(ji,jj) = z2d(ji,jj) + zztmp * zftu(ji,jj,jk) & 231 & * ( ptran(ji,jj,jk,jn) + ptran(ji+1,jj,jk,jn) ) * e1u(ji,jj) * fse3u(ji,jj,jk) 232 END DO 233 END DO 234 END DO 235 CALL lbc_lnk( z2d, 'U', -1. ) 236 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 237 z2d(:,:) = 0.e0 238 DO jk = 1, jpkm1 239 DO jj = 2, jpjm1 240 DO ji = fs_2, fs_jpim1 ! vector opt. 241 z2d(ji,jj) = z2d(ji,jj) + zztmp * zftv(ji,jj,jk) & 242 & * ( ptran(ji,jj,jk,jn) + ptran(ji,jj+1,jk,jn) ) * e2v(ji,jj) * fse3v(ji,jj,jk) 243 END DO 244 END DO 245 END DO 246 CALL lbc_lnk( z2d, 'V', -1. ) 247 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in i-direction 248 END IF 249 #endif 250 251 !!---------------------------------------------------------------------- 252 !! III - vertical trend of T & S (extra diagonal terms only) 253 !!---------------------------------------------------------------------- 254 255 ! Local constant initialization 256 ! ----------------------------- 257 ztfw(1,:,:) = 0.e0 ; ztfw(jpi,:,:) = 0.e0 258 259 ! Vertical fluxes 260 ! --------------- 261 262 ! Surface and bottom vertical fluxes set to zero 263 ztfw(:,:, 1 ) = 0.e0 ; ztfw(:,:,jpk) = 0.e0 264 265 ! interior (2=<jk=<jpk-1) 266 DO jk = 2, jpkm1 267 DO jj = 2, jpjm1 268 DO ji = fs_2, fs_jpim1 ! vector opt. 269 zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) 270 271 zmsku = 1./MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & 272 & + umask(ji-1,jj,jk-1) + umask(ji ,jj,jk), 1. ) 273 274 zmskv = 1./MAX( vmask(ji,jj ,jk-1) + vmask(ji,jj-1,jk) & 275 & + vmask(ji,jj-1,jk-1) + vmask(ji,jj ,jk), 1. ) 276 277 zcoef3 = zcoef0 * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk) 278 zcoef4 = zcoef0 * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 279 280 ztfw(ji,jj,jk) = zcoef3 * ( zdit(ji ,jj ,jk-1) + zdit(ji-1,jj ,jk) & 281 & + zdit(ji-1,jj ,jk-1) + zdit(ji ,jj ,jk) ) & 282 & + zcoef4 * ( zdjt(ji ,jj ,jk-1) + zdjt(ji ,jj-1,jk) & 283 & + zdjt(ji ,jj-1,jk-1) + zdjt(ji ,jj ,jk) ) 284 END DO 157 285 END DO 158 286 END DO 159 ENDIF 160 161 !!---------------------------------------------------------------------- 162 !! II - horizontal trend of T & S (full) 163 !!---------------------------------------------------------------------- 164 165 #if defined key_diaar5 166 !CDIR PARALLEL DO PRIVATE( zdk1t, zdk1s, zfsu ) 167 #else 168 !CDIR PARALLEL DO PRIVATE( zdk1t, zdk1s, zftu, zfsu ) 169 #endif 170 ! ! =============== 171 DO jk = 1, jpkm1 ! Horizontal slab 172 ! ! =============== 173 ! 1. Vertical tracer gradient at level jk and jk+1 174 ! ------------------------------------------------ 175 ! surface boundary condition: zdkt(jk=1)=zdkt(jk=2) 176 177 zdk1t(:,:) = ( tb(:,:,jk) - tb(:,:,jk+1) ) * tmask(:,:,jk+1) 178 zdk1s(:,:) = ( sb(:,:,jk) - sb(:,:,jk+1) ) * tmask(:,:,jk+1) 179 180 IF( jk == 1 ) THEN 181 zdkt(:,:) = zdk1t(:,:) 182 zdks(:,:) = zdk1s(:,:) 183 ELSE 184 zdkt(:,:) = ( tb(:,:,jk-1) - tb(:,:,jk) ) * tmask(:,:,jk) 185 zdks(:,:) = ( sb(:,:,jk-1) - sb(:,:,jk) ) * tmask(:,:,jk) 186 ENDIF 187 188 189 ! 2. Horizontal fluxes 190 ! -------------------- 191 192 DO jj = 1 , jpjm1 193 DO ji = 1, fs_jpim1 ! vector opt. 194 zabe1 = ( fsahtu(ji,jj,jk) + ahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 195 zabe2 = ( fsahtv(ji,jj,jk) + ahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 196 197 zmsku = 1. / MAX( tmask(ji+1,jj,jk ) + tmask(ji,jj,jk+1) & 198 & + tmask(ji+1,jj,jk+1) + tmask(ji,jj,jk ), 1. ) 199 200 zmskv = 1. / MAX( tmask(ji,jj+1,jk ) + tmask(ji,jj,jk+1) & 201 & + tmask(ji,jj+1,jk+1) + tmask(ji,jj,jk ), 1. ) 202 203 zcof1 = -fsahtu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 204 zcof2 = -fsahtv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 205 206 #if defined key_diaar5 207 zftu(ji,jj,jk) = ( zabe1 * zdit(ji,jj,jk) & 208 #else 209 zftu(ji,jj ) = ( zabe1 * zdit(ji,jj,jk) & 210 #endif 211 & + zcof1 * ( zdkt (ji+1,jj) + zdk1t(ji,jj) & 212 & + zdk1t(ji+1,jj) + zdkt (ji,jj) ) ) * umask(ji,jj,jk) 213 zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & 214 & + zcof2 * ( zdkt (ji,jj+1) + zdk1t(ji,jj) & 215 & + zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) * vmask(ji,jj,jk) 216 zfsu(ji,jj ) = ( zabe1 * zdis(ji,jj,jk) & 217 & + zcof1 * ( zdks (ji+1,jj) + zdk1s(ji,jj) & 218 & + zdk1s(ji+1,jj) + zdks (ji,jj) ) ) * umask(ji,jj,jk) 219 zfsv(ji,jj,jk) = ( zabe2 * zdjs(ji,jj,jk) & 220 & + zcof2 * ( zdks (ji,jj+1) + zdk1s(ji,jj) & 221 & + zdk1s(ji,jj+1) + zdks (ji,jj) ) ) * vmask(ji,jj,jk) 287 288 289 ! I.5 Divergence of vertical fluxes added to the general tracer trend 290 ! ------------------------------------------------------------------- 291 292 DO jk = 1, jpkm1 293 DO jj = 2, jpjm1 294 DO ji = fs_2, fs_jpim1 ! vector opt. 295 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 296 ztra = ( ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1) ) * zbtr 297 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 298 END DO 222 299 END DO 223 300 END DO 224 225 226 ! II.4 Second derivative (divergence) and add to the general trend 227 ! ---------------------------------------------------------------- 228 DO jj = 2 , jpjm1 229 DO ji = fs_2, fs_jpim1 ! vector opt. 230 zbtr= 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 231 #if defined key_diaar5 232 zta = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 233 #else 234 zta = zbtr * ( zftu(ji,jj ) - zftu(ji-1,jj ) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 235 #endif 236 zsa = zbtr * ( zfsu(ji,jj ) - zfsu(ji-1,jj ) + zfsv(ji,jj,jk) - zfsv(ji,jj-1,jk) ) 237 ta (ji,jj,jk) = ta (ji,jj,jk) + zta 238 sa (ji,jj,jk) = sa (ji,jj,jk) + zsa 239 END DO 240 END DO 241 ! ! =============== 242 END DO ! End of slab 243 ! ! =============== 244 245 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN ! Poleward diffusive heat and salt transports 246 pht_ldf(:) = ptr_vj( zftv(:,:,:) ) 247 pst_ldf(:) = ptr_vj( zfsv(:,:,:) ) 248 ENDIF 249 #if defined key_diaar5 250 zztmp = 0.5 * rau0 * rcp 251 z2d(:,:) = 0.e0 252 DO jk = 1, jpkm1 253 DO jj = 2, jpjm1 254 DO ji = fs_2, fs_jpim1 ! vector opt. 255 z2d(ji,jj) = z2d(ji,jj) + zztmp * zftu(ji,jj,jk) * ( tn(ji,jj,jk) + tn(ji+1,jj,jk) ) * e1u(ji,jj) * fse3u(ji,jj,jk) 256 END DO 257 END DO 258 END DO 259 CALL lbc_lnk( z2d, 'U', -1. ) 260 CALL iom_put( "udiff_heattr", z2d ) ! heat transport in i-direction 261 z2d(:,:) = 0.e0 262 DO jk = 1, jpkm1 263 DO jj = 2, jpjm1 264 DO ji = fs_2, fs_jpim1 ! vector opt. 265 z2d(ji,jj) = z2d(ji,jj) + zztmp * zftv(ji,jj,jk) * ( tn(ji,jj,jk) + tn(ji,jj+1,jk) ) * e2v(ji,jj) * fse3v(ji,jj,jk) 266 END DO 267 END DO 268 END DO 269 CALL lbc_lnk( z2d, 'V', -1. ) 270 CALL iom_put( "vdiff_heattr", z2d ) ! heat transport in i-direction 271 #endif 272 273 !!---------------------------------------------------------------------- 274 !! III - vertical trend of T & S (extra diagonal terms only) 275 !!---------------------------------------------------------------------- 276 277 ! Local constant initialization 278 ! ----------------------------- 279 ztfw(1,:,:) = 0.e0 ; ztfw(jpi,:,:) = 0.e0 280 zsfw(1,:,:) = 0.e0 ; zsfw(jpi,:,:) = 0.e0 281 282 283 ! Vertical fluxes 284 ! --------------- 285 286 ! Surface and bottom vertical fluxes set to zero 287 ztfw(:,:, 1 ) = 0.e0 ; ztfw(:,:,jpk) = 0.e0 288 zsfw(:,:, 1 ) = 0.e0 ; zsfw(:,:,jpk) = 0.e0 289 290 ! interior (2=<jk=<jpk-1) 291 DO jk = 2, jpkm1 292 DO jj = 2, jpjm1 293 DO ji = fs_2, fs_jpim1 ! vector opt. 294 zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) 295 296 zmsku = 1./MAX( umask(ji ,jj,jk-1) + umask(ji-1,jj,jk) & 297 & + umask(ji-1,jj,jk-1) + umask(ji ,jj,jk), 1. ) 298 299 zmskv = 1./MAX( vmask(ji,jj ,jk-1) + vmask(ji,jj-1,jk) & 300 & + vmask(ji,jj-1,jk-1) + vmask(ji,jj ,jk), 1. ) 301 302 zcoef3 = zcoef0 * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk) 303 zcoef4 = zcoef0 * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 304 305 ztfw(ji,jj,jk) = zcoef3 * ( zdit(ji ,jj ,jk-1) + zdit(ji-1,jj ,jk) & 306 & + zdit(ji-1,jj ,jk-1) + zdit(ji ,jj ,jk) ) & 307 & + zcoef4 * ( zdjt(ji ,jj ,jk-1) + zdjt(ji ,jj-1,jk) & 308 & + zdjt(ji ,jj-1,jk-1) + zdjt(ji ,jj ,jk) ) 309 310 zsfw(ji,jj,jk) = zcoef3 * ( zdis(ji ,jj ,jk-1) + zdis(ji-1,jj ,jk) & 311 & + zdis(ji-1,jj ,jk-1) + zdis(ji ,jj ,jk) ) & 312 & + zcoef4 * ( zdjs(ji ,jj ,jk-1) + zdjs(ji ,jj-1,jk) & 313 & + zdjs(ji ,jj-1,jk-1) + zdjs(ji ,jj ,jk) ) 314 END DO 315 END DO 316 END DO 317 318 319 ! I.5 Divergence of vertical fluxes added to the general tracer trend 320 ! ------------------------------------------------------------------- 321 322 DO jk = 1, jpkm1 323 DO jj = 2, jpjm1 324 DO ji = fs_2, fs_jpim1 ! vector opt. 325 zbtr = 1. / ( e1t(ji,jj)*e2t(ji,jj)*fse3t(ji,jj,jk) ) 326 zta = ( ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1) ) * zbtr 327 zsa = ( zsfw(ji,jj,jk) - zsfw(ji,jj,jk+1) ) * zbtr 328 ta(ji,jj,jk) = ta(ji,jj,jk) + zta 329 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 330 END DO 331 END DO 301 ! 332 302 END DO 333 303 ! -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traldf_lap.F90
r1152 r2024 2 2 !!============================================================================== 3 3 !! *** MODULE traldf_lap *** 4 !! Ocean activetracers: horizontal component of the lateral tracer mixing trend4 !! Ocean tracers: horizontal component of the lateral tracer mixing trend 5 5 !!============================================================================== 6 6 !! History : OPA ! 87-06 (P. Andrich, D. L Hostis) Original code 7 !! ! 91-11 (G. Madec) 8 !! ! 95-11 (G. Madec) suppress volumetric scale factors 9 !! ! 96-01 (G. Madec) statement function for e3 10 !! NEMO ! 02-06 (G. Madec) F90: Free form and module 11 !! 1.0 ! 04-08 (C. Talandier) New trends organization 12 !! ! 05-11 (G. Madec) add zps case 13 !! 3.0 ! 10-06 (C. Ethe, G. Madec) Merge TRA-TRC 14 !!---------------------------------------------------------------------- 7 15 !!---------------------------------------------------------------------- 8 16 !! tra_ldf_lap : update the tracer trend with the horizontal diffusion … … 13 21 USE dom_oce ! ocean space and time domain 14 22 USE ldftra_oce ! ocean active tracers: lateral physics 15 USE trdmod ! ocean active tracers trends16 USE trdmod_oce ! ocean variables trends17 23 USE in_out_manager ! I/O manager 18 24 USE diaptr ! poleward transport diagnostics 19 USE prtctl ! Print control20 25 21 26 … … 25 30 !! * Routine accessibility 26 31 PUBLIC tra_ldf_lap ! routine called by step.F90 32 33 REAL(wp), DIMENSION(jpi,jpj) :: e1ur, e2vr ! scale factor coefficients 27 34 28 35 !! * Substitutions … … 38 45 CONTAINS 39 46 40 SUBROUTINE tra_ldf_lap( kt ) 47 SUBROUTINE tra_ldf_lap( kt , cdtype, pgtu, pgtv, & 48 & ptrab, ptraa , kjpt ) 41 49 !!---------------------------------------------------------------------- 42 50 !! *** ROUTINE tra_ldf_lap *** … … 47 55 !! ** Method : Second order diffusive operator evaluated using before 48 56 !! fields (forward time scheme). The horizontal diffusive trends of 49 !! t emperature (idem for salinity)is given by:57 !! the tracer is given by: 50 58 !! difft = 1/(e1t*e2t*e3t) { di-1[ aht e2u*e3u/e1u di(tb) ] 51 59 !! + dj-1[ aht e1v*e3v/e2v dj(tb) ] } … … 53 61 !! difft = 1/(e1t*e2t) { di-1[ aht e2u/e1u di(tb) ] 54 62 !! + dj-1[ aht e1v/e2v dj(tb) ] } 55 !! Add this trend to the general tracer trend (ta,sa):56 !! (ta,sa) = (ta,sa) + ( difft , diffs )63 !! Add this trend to the general tracer trend pta : 64 !! pta = pta + difft 57 65 !! 58 !! ** Action : - Update (ta,sa)arrays with the before iso-level66 !! ** Action : - Update pta arrays with the before iso-level 59 67 !! harmonic mixing trend. 60 !!61 !! History :62 !! 1.0 ! 87-06 (P. Andrich, D. L Hostis) Original code63 !! ! 91-11 (G. Madec)64 !! ! 95-11 (G. Madec) suppress volumetric scale factors65 !! ! 96-01 (G. Madec) statement function for e366 !! 8.5 ! 02-06 (G. Madec) F90: Free form and module67 !! 9.0 ! 04-08 (C. Talandier) New trends organization68 !! ! 05-11 (G. Madec) add zps case69 68 !!---------------------------------------------------------------------- 70 USE oce , ztu => ua, & ! use ua as workspace71 & zsu => va ! use va as workspace72 73 !! 74 INTEGER , INTENT( in ) :: kt! ocean time-step index75 76 !! * Local save77 REAL(wp) , DIMENSION(jpi,jpj), SAVE :: &78 ze1ur, ze2vr, zbtr2 ! scale factor coefficients79 80 !! 81 INTEGER :: ji, jj, jk 82 INTEGER :: iku, ikv ! temporary integers69 !!* Module used 70 USE oce , ztu => ua ! use ua as workspace 71 USE oce , ztv => va ! use va as workspace 72 !!* Arguments 73 INTEGER , INTENT(in ) :: kt ! ocean time-step index 74 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 75 INTEGER , INTENT(in ) :: kjpt ! number of tracers 76 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,kjpt ) :: pgtu, pgtv ! tracer gradient at pstep levels 77 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 78 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 79 !!* Local declarations 80 INTEGER :: ji, jj, jk, jn ! dummy loop indices 81 INTEGER :: iku, ikv ! temporary integers 83 82 REAL(wp) :: & 84 zabe1, zta, & ! temporary scalars 85 zabe2, zsa, zbtr ! " " 86 REAL(wp), DIMENSION(jpi,jpj,jpk) :: & 87 ztv, zsv ! 3D workspace 83 zabe1, zabe2, ztra, zbtr ! temporary scalars 88 84 !!---------------------------------------------------------------------- 89 85 … … 92 88 IF(lwp) WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion' 93 89 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 94 ze1ur(:,:) = e2u(:,:) / e1u(:,:) 95 ze2vr(:,:) = e1v(:,:) / e2v(:,:) 96 zbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 90 e1ur(:,:) = e2u(:,:) / e1u(:,:) 91 e2vr(:,:) = e1v(:,:) / e2v(:,:) 97 92 ENDIF 98 99 ! ! ============= 100 DO jk = 1, jpkm1 ! Vertical slab 101 ! ! ============= 102 ! 1. First derivative (gradient) 103 ! ------------------- 104 DO jj = 1, jpjm1 105 DO ji = 1, fs_jpim1 ! vector opt. 106 #if defined key_zco 107 zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * ze1ur(ji,jj) 108 zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * ze2vr(ji,jj) 109 #else 110 zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * ze1ur(ji,jj) * fse3u(ji,jj,jk) 111 zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * ze2vr(ji,jj) * fse3v(ji,jj,jk) 112 #endif 113 ztu(ji,jj,jk) = zabe1 * ( tb(ji+1,jj ,jk) - tb(ji,jj,jk) ) 114 zsu(ji,jj,jk) = zabe1 * ( sb(ji+1,jj ,jk) - sb(ji,jj,jk) ) 115 ztv(ji,jj,jk) = zabe2 * ( tb(ji ,jj+1,jk) - tb(ji,jj,jk) ) 116 zsv(ji,jj,jk) = zabe2 * ( sb(ji ,jj+1,jk) - sb(ji,jj,jk) ) 117 END DO 118 END DO 119 IF( ln_zps ) THEN ! set gradient at partial step level 93 94 ! 95 DO jn = 1, kjpt ! tracer loop 96 ! ! =========== 97 ! 98 DO jk = 1, jpkm1 99 ! 100 ! 1. First derivative (gradient) 101 ! ------------------- 120 102 DO jj = 1, jpjm1 121 103 DO ji = 1, fs_jpim1 ! vector opt. 122 ! last level 123 iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1 124 ikv = MIN ( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1 125 IF( iku == jk ) THEN 126 zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * ze1ur(ji,jj) * fse3u(ji,jj,iku) 127 ztu(ji,jj,jk) = zabe1 * gtu(ji,jj) 128 zsu(ji,jj,jk) = zabe1 * gsu(ji,jj) 129 ENDIF 130 IF( ikv == jk ) THEN 131 zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * ze2vr(ji,jj) * fse3v(ji,jj,ikv) 132 ztv(ji,jj,jk) = zabe2 * gtv(ji,jj) 133 zsv(ji,jj,jk) = zabe2 * gsv(ji,jj) 134 ENDIF 104 zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * e1ur(ji,jj) * fse3u(ji,jj,jk) 105 zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * e2vr(ji,jj) * fse3v(ji,jj,jk) 106 ztu(ji,jj,jk) = zabe1 * ( ptrab(ji+1,jj ,jk,jn) - ptrab(ji,jj,jk,jn) ) 107 ztv(ji,jj,jk) = zabe2 * ( ptrab(ji ,jj+1,jk,jn) - ptrab(ji,jj,jk,jn) ) 135 108 END DO 136 109 END DO 137 ENDIF 110 IF( ln_zps ) THEN ! set gradient at partial step level 111 DO jj = 1, jpjm1 112 DO ji = 1, fs_jpim1 ! vector opt. 113 ! last level 114 iku = MIN ( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1 115 ikv = MIN ( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1 116 IF( iku == jk ) THEN 117 zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * e1ur(ji,jj) * fse3u(ji,jj,iku) 118 ztu(ji,jj,jk) = zabe1 * pgtu(ji,jj,jn) 119 ENDIF 120 IF( ikv == jk ) THEN 121 zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * e2vr(ji,jj) * fse3v(ji,jj,ikv) 122 ztv(ji,jj,jk) = zabe2 * pgtv(ji,jj,jn) 123 ENDIF 124 END DO 125 END DO 126 ENDIF 138 127 139 128 140 ! 2. Second derivative (divergence) 141 ! -------------------- 142 DO jj = 2, jpjm1 143 DO ji = fs_2, fs_jpim1 ! vector opt. 144 #if defined key_zco 145 zbtr = zbtr2(ji,jj) 146 #else 147 zbtr = zbtr2(ji,jj) / fse3t(ji,jj,jk) 148 #endif 149 ! horizontal diffusive trends 150 zta = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 151 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 152 zsa = zbtr * ( zsu(ji,jj,jk) - zsu(ji-1,jj,jk) & 153 & + zsv(ji,jj,jk) - zsv(ji,jj-1,jk) ) 154 ! add it to the general tracer trends 155 ta(ji,jj,jk) = ta(ji,jj,jk) + zta 156 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa 157 END DO 158 END DO 159 ! ! ============= 160 END DO ! End of slab 161 ! ! ============= 162 163 ! "zonal" mean lateral diffusive heat and salt transport 164 IF( ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 165 IF( lk_zco ) THEN ! z-coordinate - full step (1D arrays) 166 DO jk = 1, jpkm1 167 DO jj = 2, jpjm1 168 DO ji = fs_2, fs_jpim1 ! vector opt. 169 ztv(ji,jj,jk) = ztv(ji,jj,jk) * fse3v(ji,jj,jk) 170 zsv(ji,jj,jk) = zsv(ji,jj,jk) * fse3v(ji,jj,jk) 171 END DO 129 ! 2. Second derivative (divergence) added to the general tracer trends 130 ! --------------------------------------------------------------------- 131 DO jj = 2, jpjm1 132 DO ji = fs_2, fs_jpim1 ! vector opt. 133 zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 134 ! horizontal diffusive trends 135 ztra = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 136 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 137 ! add it to the general tracer trends 138 ptraa(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) + ztra 172 139 END DO 173 140 END DO 141 ! ! ============= 142 END DO ! End of slab 143 ! ! ============= 144 ! "Poleward" diffusive heat or salt transports 145 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nf_ptr ) == 0 ) ) THEN 146 IF( jn == jp_tem) pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 147 IF( jn == jp_sal) pst_ldf(:) = ptr_vj( ztv(:,:,:) ) 174 148 ENDIF 175 pht_ldf(:) = ptr_vj( ztv(:,:,:) ) 176 pst_ldf(:) = ptr_vj( zsv(:,:,:) ) 177 ENDIF 178 149 ! 150 END DO 151 ! 179 152 END SUBROUTINE tra_ldf_lap 180 153 -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/tranpc.F90
r1537 r2024 16 16 USE dom_oce ! ocean space and time domain 17 17 USE zdf_oce ! ocean vertical physics 18 USE trdmod 19 USE trd mod_oce ! ocean variablestrends18 USE trdmod_oce ! ocean active tracer trends 19 USE trdtra ! ocean active tracer trends 20 20 USE eosbn2 ! equation of state (eos routine) 21 21 USE lbclnk ! lateral boundary conditions (or mpp link) … … 55 55 !! References : Madec, et al., 1991, JPO, 21, 9, 1349-1371. 56 56 !!---------------------------------------------------------------------- 57 USE oce, ONLY : ztrdt => ua ! use ua as 3D workspace58 USE oce, ONLY : ztrds => va ! use va as 3D workspace59 57 !! 60 58 INTEGER, INTENT(in) :: kt ! ocean time-step index … … 68 66 REAL(wp), DIMENSION(jpi,jpk) :: zwx, zwy, zwz ! 2D arrays 69 67 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrhop ! 3D arrays 68 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 70 69 !!---------------------------------------------------------------------- 71 70 … … 75 74 inpci = 0 76 75 77 CALL eos( ta, sa, rhd, zrhop ) ! Potential density 78 79 80 IF( l_trdtra ) THEN ! Save ta and sa trends 81 ztrdt(:,:,:) = ta(:,:,:) 82 ztrds(:,:,:) = sa(:,:,:) 76 CALL eos( tsa(:,:,:,jp_tem), tsa(:,:,:,jp_sal), rhd, zrhop ) ! Potential density 77 78 IF( l_trdtra ) THEN !* Save ta and sa trends 79 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 80 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsa(:,:,:,jp_sal) 83 81 ENDIF 84 82 … … 151 149 ! 152 150 ze3tot= fse3t(ji,jj,ikup) 153 zta = t a (ji,jj,ikup)154 zsa = sa (ji,jj,ikup)151 zta = tsa (ji,jj,ikup,jp_tem) 152 zsa = tsa (ji,jj,ikup,jp_sal) 155 153 zraua = zrhop(ji,jj,ikup) 156 154 ! … … 162 160 ze3dwn = fse3t(ji,jj,jkdown) 163 161 ze3tot = ze3tot + ze3dwn 164 zta = ( zta*(ze3tot-ze3dwn) + t a(ji,jj,jkdown)*ze3dwn )/ze3tot165 zsa = ( zsa*(ze3tot-ze3dwn) + sa(ji,jj,jkdown)*ze3dwn )/ze3tot162 zta = ( zta*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_tem)*ze3dwn )/ze3tot 163 zsa = ( zsa*(ze3tot-ze3dwn) + tsa(ji,jj,jkdown,jp_sal)*ze3dwn )/ze3tot 166 164 zraua = ( zraua*(ze3tot-ze3dwn) + zrhop(ji,jj,jkdown)*ze3dwn )/ze3tot 167 165 inpci = inpci+1 … … 171 169 ! 172 170 DO jkp = ikup, ikdown-1 173 t a(ji,jj,jkp) = zta174 sa(ji,jj,jkp) = zsa175 zrhop(ji,jj,jkp ) = zraua171 tsa (ji,jj,jkp,jp_tem) = zta 172 tsa (ji,jj,jkp,jp_sal) = zsa 173 zrhop(ji,jj,jkp ) = zraua 176 174 END DO 177 175 IF (ikdown == ikbot-1 .AND. zraua >= zrhop(ji,jj,ikdown) ) THEN 178 t a(ji,jj,ikdown) = zta179 sa(ji,jj,ikdown) = zsa180 zrhop(ji,jj,ikdown ) = zraua176 tsa (ji,jj,jkp,jp_tem) = zta 177 tsa (ji,jj,jkp,jp_sal) = zsa 178 zrhop(ji,jj,ikdown ) = zraua 181 179 ENDIF 182 180 END DO … … 191 189 ! 192 190 IF( l_trdtra ) THEN ! save the Non penetrative mixing trends for diagnostic 193 ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 194 ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 195 CALL trd_mod(ztrdt, ztrds, jptra_trd_npc, 'TRA', kt) 191 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 192 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 193 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_npc, ztrdt ) 194 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_npc, ztrds ) 195 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 196 196 ENDIF 197 197 198 198 ! Lateral boundary conditions on ( ta, sa ) ( Unchanged sign) 199 199 ! ------------------------------============ 200 CALL lbc_lnk( t a, 'T', 1. )201 CALL lbc_lnk( sa, 'T', 1. )200 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) 201 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 202 202 203 203 -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/tranxt.F90
r1970 r2024 28 28 USE dynspg_oce ! surface pressure gradient variables 29 29 USE dynhpg ! hydrostatic pressure gradient 30 USE trdmod_oce ! ocean variables trends31 USE trd mod! ocean active tracers trends30 USE trdmod_oce ! ocean space and time domain variables 31 USE trdtra ! ocean active tracers trends 32 32 USE phycst 33 33 USE obctra ! open boundary condition (obc_tra routine) … … 36 36 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 37 37 USE prtctl ! Print control 38 USE traswp ! swap array 38 39 USE agrif_opa_update 39 40 USE agrif_opa_interp 40 USE obc_oce 41 USE obc_oce 41 42 42 43 IMPLICIT NONE 43 44 PRIVATE 44 45 45 PUBLIC tra_nxt ! routine called by step.F90 46 PUBLIC tra_nxt ! routine called by step.F90 47 PUBLIC tra_nxt_fix ! to be used in trcnxt 48 PUBLIC tra_nxt_vvl ! to be used in trcnxt 46 49 47 50 REAL(wp), DIMENSION(jpk) :: r2dt_t ! vertical profile time step, =2*rdttra (leapfrog) or =rdttra (Euler) … … 81 84 !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) 82 85 !!---------------------------------------------------------------------- 83 USE oce, ONLY : ztrdt => ua ! use ua as 3D workspace84 USE oce, ONLY : ztrds => va ! use va as 3D workspace85 !!86 86 INTEGER, INTENT(in) :: kt ! ocean time-step index 87 87 !! 88 88 INTEGER :: jk ! dummy loop indices 89 89 REAL(wp) :: zfact ! temporary scalars 90 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 91 90 92 !!---------------------------------------------------------------------- 91 93 … … 98 100 ! Update after tracer on domain lateral boundaries 99 101 ! 100 CALL lbc_lnk( ta, 'T', 1. ) ! local domain boundaries (T-point, unchanged sign) 101 CALL lbc_lnk( sa, 'T', 1. ) 102 ! 102 CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) ! local domain boundaries (T-point, unchanged sign) 103 CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1. ) 104 ! 105 #if defined key_obc || defined key_bdy || defined key_agrif 106 CALL tra_unswap 107 #endif 103 108 #if defined key_obc 104 109 IF( lk_obc ) CALL obc_tra( kt ) ! OBC open boundaries … … 110 115 CALL Agrif_tra ! AGRIF zoom boundaries 111 116 #endif 117 #if defined key_obc || defined key_bdy || defined key_agrif 118 CALL tra_swap 119 #endif 112 120 113 121 ! set time step size (Euler/Leapfrog) … … 117 125 118 126 ! trends computation initialisation 119 IF( l_trdtra ) THEN !store now fields before applying the Asselin filter120 ztrdt(:,:,:) = tn(:,:,:)121 ztrds(:,:,:) = sn(:,:,:)127 IF( l_trdtra ) THEN !* store now fields before applying the Asselin filter 128 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsn(:,:,:,jp_tem) 129 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsn(:,:,:,jp_sal) 122 130 ENDIF 123 131 124 132 ! Leap-Frog + Asselin filter time stepping 125 IF( lk_vvl ) THEN ; CALL tra_nxt_vvl( kt ) ! variable volume level (vvl) 126 ELSE ; CALL tra_nxt_fix( kt ) ! fixed volume level 133 IF( lk_vvl ) THEN ; CALL tra_nxt_vvl( kt , nit000, & 134 & tsb, tsn , tsa, jpts ) ! variable volume level (vvl) 135 ELSE ; CALL tra_nxt_fix( kt , nit000, & 136 & tsb, tsn , tsa, jpts ) ! fixed volume level 127 137 ENDIF 128 138 129 139 #if defined key_agrif 140 CALL tra_unswap 130 141 ! Update tracer at AGRIF zoom boundaries 131 142 IF( .NOT.Agrif_Root() ) CALL Agrif_Update_Tra( kt ) ! children only 143 CALL tra_swap 132 144 #endif 133 145 … … 136 148 DO jk = 1, jpkm1 137 149 zfact = 1.e0 / r2dt_t(jk) 138 ztrdt(:,:,jk) = ( t b(:,:,jk) - ztrdt(:,:,jk) ) * zfact139 ztrds(:,:,jk) = ( sb(:,:,jk) - ztrds(:,:,jk) ) * zfact150 ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact 151 ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact 140 152 END DO 141 CALL trd_mod( ztrdt, ztrds, jptra_trd_atf, 'TRA', kt ) 153 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_atf, ztrdt ) 154 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_atf, ztrds ) 155 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 142 156 END IF 143 157 144 158 ! ! control print 145 IF(ln_ctl) CALL prt_ctl( tab3d_1=t n, clinfo1=' nxt - Tn: ', mask1=tmask, &146 & tab3d_2= sn, clinfo2= ' Sn: ', mask2=tmask )159 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' nxt - Tn: ', mask1=tmask, & 160 & tab3d_2=tsn(:,:,:,jp_sal), clinfo2= ' Sn: ', mask2=tmask ) 147 161 ! 148 162 END SUBROUTINE tra_nxt 149 163 150 151 SUBROUTINE tra_nxt_fix( kt)164 SUBROUTINE tra_nxt_fix( kt , kit000, & 165 & ptrab, ptran , ptraa, kjpt ) 152 166 !!---------------------------------------------------------------------- 153 167 !! *** ROUTINE tra_nxt_fix *** … … 171 185 !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) 172 186 !!---------------------------------------------------------------------- 173 INTEGER, INTENT(in) :: kt ! ocean time-step index 174 !! 175 INTEGER :: ji, jj, jk ! dummy loop indices 176 REAL(wp) :: ztm, ztf ! temporary scalars 177 REAL(wp) :: zsm, zsf ! - - 178 !!---------------------------------------------------------------------- 179 180 IF( kt == nit000 ) THEN 187 INTEGER , INTENT(in ) :: kt ! ocean time-step index 188 INTEGER , INTENT(in ) :: kit000 ! first time-step index 189 INTEGER , INTENT(in ) :: kjpt ! number of tracers 190 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before tracer fields 191 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptran ! now tracer fields 192 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 193 !! 194 INTEGER :: ji, jj, jk, jn ! dummy loop indices 195 REAL(wp) :: ztm, ztf ! temporary scalars 196 !!---------------------------------------------------------------------- 197 198 IF( kt == kit000 ) THEN 181 199 IF(lwp) WRITE(numout,*) 182 200 IF(lwp) WRITE(numout,*) 'tra_nxt_fix : time stepping' … … 188 206 ! ! ----------------------- ! 189 207 ! 190 IF( neuler == 0 .AND. kt == nit000 ) THEN ! Euler time-stepping at first time-step 191 DO jk = 1, jpkm1 ! (only swap) 192 DO jj = 1, jpj 193 DO ji = 1, jpi 194 tn(ji,jj,jk) = ta(ji,jj,jk) ! tb <-- tn 195 sn(ji,jj,jk) = sa(ji,jj,jk) 208 IF( neuler == 0 .AND. kt == kit000 ) THEN ! Euler time-stepping at first time-step 209 ! ! (only swap) 210 DO jn = 1, kjpt 211 DO jk = 1, jpkm1 212 DO jj = 1, jpj 213 DO ji = 1, jpi 214 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! ptrab <-- ptran 215 END DO 196 216 END DO 197 217 END DO 198 218 END DO 199 219 ELSE ! general case (Leapfrog + Asselin filter 200 DO jk = 1, jpkm1 201 DO jj = 1, jpj 202 DO ji = 1, jpi 203 ztm = 0.25 * ( ta(ji,jj,jk) + 2.* tn(ji,jj,jk) + tb(ji,jj,jk) ) ! mean t 204 zsm = 0.25 * ( sa(ji,jj,jk) + 2.* sn(ji,jj,jk) + sb(ji,jj,jk) ) 205 ztf = atfp * ( ta(ji,jj,jk) - 2.* tn(ji,jj,jk) + tb(ji,jj,jk) ) ! Asselin filter on t 206 zsf = atfp * ( sa(ji,jj,jk) - 2.* sn(ji,jj,jk) + sb(ji,jj,jk) ) 207 tb(ji,jj,jk) = tn(ji,jj,jk) + ztf ! tb <-- filtered tn 208 sb(ji,jj,jk) = sn(ji,jj,jk) + zsf 209 tn(ji,jj,jk) = ta(ji,jj,jk) ! tn <-- ta 210 sn(ji,jj,jk) = sa(ji,jj,jk) 211 ta(ji,jj,jk) = ztm ! ta <-- mean t 212 sa(ji,jj,jk) = zsm 220 DO jn = 1, kjpt 221 DO jk = 1, jpkm1 222 DO jj = 1, jpj 223 DO ji = 1, jpi 224 ztm = 0.25 * ( ptraa(ji,jj,jk,jn) + 2.* ptran(ji,jj,jk,jn) + ptrab(ji,jj,jk,jn) ) ! mean ptra 225 ztf = atfp * ( ptraa(ji,jj,jk,jn) - 2.* ptran(ji,jj,jk,jn) + ptran(ji,jj,jk,jn) ) ! Asselin filter on ptra 226 ptrab(ji,jj,jk,jn) = ptran(ji,jj,jk,jn) + ztf ! ptrab <-- filtered ptran 227 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! ptran <-- ptraa 228 ptraa(ji,jj,jk,jn) = ztm ! ptraa <-- mean ptra 229 END DO 213 230 END DO 214 231 END DO … … 219 236 ! ! ----------------------- ! 220 237 ! 221 IF( neuler == 0 .AND. kt == nit000 ) THEN ! Euler time-stepping at first time-step 222 DO jk = 1, jpkm1 223 DO jj = 1, jpj 224 DO ji = 1, jpi 225 tn(ji,jj,jk) = ta(ji,jj,jk) ! tn <-- ta 226 sn(ji,jj,jk) = sa(ji,jj,jk) 238 IF( neuler == 0 .AND. kt == kit000 ) THEN ! Euler time-stepping at first time-step 239 DO jn = 1, kjpt 240 DO jk = 1, jpkm1 241 DO jj = 1, jpj 242 DO ji = 1, jpi 243 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! ptran <-- ptraa 244 END DO 227 245 END DO 228 246 END DO 229 247 END DO 230 248 ELSE ! general case (Leapfrog + Asselin filter 231 DO jk = 1, jpkm1 232 DO jj = 1, jpj 233 DO ji = 1, jpi 234 ztf = atfp * ( ta(ji,jj,jk) - 2.* tn(ji,jj,jk) + tb(ji,jj,jk) ) ! Asselin filter on t 235 zsf = atfp * ( sa(ji,jj,jk) - 2.* sn(ji,jj,jk) + sb(ji,jj,jk) ) 236 tb(ji,jj,jk) = tn(ji,jj,jk) + ztf ! tb <-- filtered tn 237 sb(ji,jj,jk) = sn(ji,jj,jk) + zsf 238 tn(ji,jj,jk) = ta(ji,jj,jk) ! tn <-- ta 239 sn(ji,jj,jk) = sa(ji,jj,jk) 249 DO jn = 1, kjpt 250 DO jk = 1, jpkm1 251 DO jj = 1, jpj 252 DO ji = 1, jpi 253 ztf = atfp * ( ptraa(ji,jj,jk,jn) - 2.* ptran(ji,jj,jk,jn) + ptrab(ji,jj,jk,jn) ) ! Asselin filter on t 254 ptrab(ji,jj,jk,jn) = ptran(ji,jj,jk,jn) + ztf ! ptrab <-- filtered ptran 255 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! ptran <-- ptraa 256 END DO 240 257 END DO 241 258 END DO 242 259 END DO 243 260 ENDIF 261 ! 244 262 ENDIF 245 263 ! … … 247 265 248 266 249 SUBROUTINE tra_nxt_vvl( kt ) 267 SUBROUTINE tra_nxt_vvl( kt , kit000, & 268 & ptrab, ptran , ptraa, kjpt ) 250 269 !!---------------------------------------------------------------------- 251 270 !! *** ROUTINE tra_nxt_vvl *** … … 271 290 !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) 272 291 !!---------------------------------------------------------------------- 273 INTEGER, INTENT(in) :: kt ! ocean time-step index 292 INTEGER , INTENT(in ) :: kt ! ocean time-step index 293 INTEGER , INTENT(in ) :: kit000 ! first time-step index 294 INTEGER , INTENT(in ) :: kjpt ! number of tracers 295 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before tracer fields 296 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptran ! now tracer fields 297 REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 274 298 !! 275 INTEGER :: ji, jj, jk ! dummy loop indices299 INTEGER :: ji, jj, jk, jn ! dummy loop indices 276 300 REAL(wp) :: ztm , ztc_f , ztf , ztca, ztcn, ztcb ! temporary scalar 277 REAL(wp) :: zsm , zsc_f , zsf , zsca, zscn, zscb ! - -278 301 REAL(wp) :: ze3mr, ze3fr ! - - 279 302 REAL(wp) :: ze3t_b, ze3t_n, ze3t_a, ze3t_f ! - - 280 303 !!---------------------------------------------------------------------- 281 304 282 IF( kt == nit000 ) THEN305 IF( kt == kit000 ) THEN 283 306 IF(lwp) WRITE(numout,*) 284 307 IF(lwp) WRITE(numout,*) 'tra_nxt_vvl : time stepping' 285 308 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 286 309 ENDIF 287 310 ! 288 311 ! ! ----------------------- ! 289 312 IF( ln_dynhpg_imp ) THEN ! semi-implicite hpg case ! 290 313 ! ! ----------------------- ! 291 314 ! 292 IF( neuler == 0 .AND. kt == nit000 ) THEN ! Euler time-stepping at first time-step 293 DO jk = 1, jpkm1 ! (only swap) 294 DO jj = 1, jpj 295 DO ji = 1, jpi 296 tn(ji,jj,jk) = ta(ji,jj,jk) ! tn <-- ta 297 sn(ji,jj,jk) = sa(ji,jj,jk) 315 IF( neuler == 0 .AND. kt == kit000 ) THEN ! Euler time-stepping at first time-step 316 DO jn = 1, kjpt ! (only swap) 317 DO jk = 1, jpkm1 318 DO jj = 1, jpj 319 DO ji = 1, jpi 320 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! tn <-- ta 321 END DO 298 322 END DO 299 323 END DO 300 324 END DO 301 325 ELSE 302 DO jk = 1, jpkm1 303 DO jj = 1, jpj 304 DO ji = 1, jpi 305 ze3t_b = fse3t_b(ji,jj,jk) 306 ze3t_n = fse3t_n(ji,jj,jk) 307 ze3t_a = fse3t_a(ji,jj,jk) 308 ! ! tracer content at Before, now and after 309 ztcb = tb(ji,jj,jk) * ze3t_b ; zscb = sb(ji,jj,jk) * ze3t_b 310 ztcn = tn(ji,jj,jk) * ze3t_n ; zscn = sn(ji,jj,jk) * ze3t_n 311 ztca = ta(ji,jj,jk) * ze3t_a ; zsca = sa(ji,jj,jk) * ze3t_a 312 ! 313 ! ! Asselin filter on thickness and tracer content 314 ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 315 ztc_f = atfp * ( ztca - 2.* ztcn + ztcb ) 316 zsc_f = atfp * ( zsca - 2.* zscn + zscb ) 317 ! 318 ! ! filtered tracer including the correction 319 ze3fr = 1.e0 / ( ze3t_n + ze3t_f ) 320 ztf = ze3fr * ( ztcn + ztc_f ) 321 zsf = ze3fr * ( zscn + zsc_f ) 322 ! ! mean thickness and tracer 323 ze3mr = 1.e0 / ( ze3t_a + 2.* ze3t_n + ze3t_b ) 324 ztm = ze3mr * ( ztca + 2.* ztcn + ztcb ) 325 zsm = ze3mr * ( zsca + 2.* zscn + zscb ) 326 !!gm mean e3t have to be saved and used in dynhpg or it can be recomputed in dynhpg !! 327 !!gm e3t_m(ji,jj,jk) = 0.25 / ze3mr 328 ! ! swap of arrays 329 tb(ji,jj,jk) = ztf ! tb <-- tn + filter 330 sb(ji,jj,jk) = zsf 331 tn(ji,jj,jk) = ta(ji,jj,jk) ! tn <-- ta 332 sn(ji,jj,jk) = sa(ji,jj,jk) 333 ta(ji,jj,jk) = ztm ! ta <-- mean t 334 sa(ji,jj,jk) = zsm 326 DO jn = 1, kjpt ! (only swap) 327 DO jk = 1, jpkm1 328 DO jj = 1, jpj 329 DO ji = 1, jpi 330 ze3t_b = fse3t_b(ji,jj,jk) 331 ze3t_n = fse3t_n(ji,jj,jk) 332 ze3t_a = fse3t_a(ji,jj,jk) 333 ! ! tracer content at Before, now and after 334 ztcb = ptrab(ji,jj,jk,jn) * ze3t_b 335 ztcn = ptran(ji,jj,jk,jn) * ze3t_n 336 ztca = ptraa(ji,jj,jk,jn) * ze3t_a 337 ! 338 ! ! Asselin filter on thickness and tracer content 339 ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 340 ztc_f = atfp * ( ztca - 2.* ztcn + ztcb ) 341 ! 342 ! ! filtered tracer including the correction 343 ze3fr = 1.e0 / ( ze3t_n + ze3t_f ) 344 ztf = ze3fr * ( ztcn + ztc_f ) 345 ! ! mean thickness and tracer 346 ze3mr = 1.e0 / ( ze3t_a + 2.* ze3t_n + ze3t_b ) 347 ztm = ze3mr * ( ztca + 2.* ztcn + ztcb ) 348 !!gm mean e3t have to be saved and used in dynhpg or it can be recomputed in dynhpg !! 349 !!gm e3t_m(ji,jj,jk) = 0.25 / ze3mr 350 ! ! swap of arrays 351 ptrab(ji,jj,jk,jn) = ztf ! ptrab <-- ptran + filter 352 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! ptran <-- ptraa 353 ptraa(ji,jj,jk,jn) = ztm ! ptraa <-- mean t 354 END DO 335 355 END DO 336 356 END DO … … 341 361 ! ! ----------------------- ! 342 362 ! 343 IF( neuler == 0 .AND. kt == nit000 ) THEN ! case of Euler time-stepping at first time-step 344 DO jk = 1, jpkm1 ! No filter nor thickness weighting computation required 345 DO jj = 1, jpj ! ONLY swap 346 DO ji = 1, jpi 347 tn(ji,jj,jk) = ta(ji,jj,jk) ! tn <-- ta 348 sn(ji,jj,jk) = sa(ji,jj,jk) 363 IF( neuler == 0 .AND. kt == kit000 ) THEN ! case of Euler time-stepping at first time-step 364 DO jn = 1, kjpt ! No filter nor thickness weighting computation required 365 DO jk = 1, jpkm1 ! ONLY swap 366 DO jj = 1, jpj 367 DO ji = 1, jpi 368 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! tn <-- ta 369 END DO 349 370 END DO 350 371 END DO … … 352 373 ! ! general case (Leapfrog + Asselin filter) 353 374 ELSE ! apply filter on thickness weighted tracer and swap 354 DO jk = 1, jpkm1 355 DO jj = 1, jpj 356 DO ji = 1, jpi 357 ze3t_b = fse3t_b(ji,jj,jk) 358 ze3t_n = fse3t_n(ji,jj,jk) 359 ze3t_a = fse3t_a(ji,jj,jk) 360 ! ! tracer content at Before, now and after 361 ztcb = tb(ji,jj,jk) * ze3t_b ; zscb = sb(ji,jj,jk) * ze3t_b 362 ztcn = tn(ji,jj,jk) * ze3t_n ; zscn = sn(ji,jj,jk) * ze3t_n 363 ztca = ta(ji,jj,jk) * ze3t_a ; zsca = sa(ji,jj,jk) * ze3t_a 364 ! 365 ! ! Asselin filter on thickness and tracer content 366 ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 367 ztc_f = atfp * ( ztca - 2.* ztcn + ztcb ) 368 zsc_f = atfp * ( zsca - 2.* zscn + zscb ) 369 ! 370 ! ! filtered tracer including the correction 371 ze3fr = 1.e0 / ( ze3t_n + ze3t_f ) 372 ztf = ( ztcn + ztc_f ) * ze3fr 373 zsf = ( zscn + zsc_f ) * ze3fr 374 ! ! swap of arrays 375 tb(ji,jj,jk) = ztf ! tb <-- tn filtered 376 sb(ji,jj,jk) = zsf 377 tn(ji,jj,jk) = ta(ji,jj,jk) ! tn <-- ta 378 sn(ji,jj,jk) = sa(ji,jj,jk) 375 DO jn = 1, kjpt 376 DO jk = 1, jpkm1 377 DO jj = 1, jpj 378 DO ji = 1, jpi 379 ze3t_b = fse3t_b(ji,jj,jk) 380 ze3t_n = fse3t_n(ji,jj,jk) 381 ze3t_a = fse3t_a(ji,jj,jk) 382 ! ! tracer content at Before, now and after 383 ztcb = ptrab(ji,jj,jk,jn) * ze3t_b 384 ztcn = ptran(ji,jj,jk,jn) * ze3t_n 385 ztca = ptraa(ji,jj,jk,jn) * ze3t_a 386 ! 387 ! ! Asselin filter on thickness and tracer content 388 ze3t_f = atfp * ( ze3t_a - 2.* ze3t_n + ze3t_b ) 389 ztc_f = atfp * ( ztca - 2.* ztcn + ztcb ) 390 ! 391 ! ! filtered tracer including the correction 392 ze3fr = 1.e0 / ( ze3t_n + ze3t_f ) 393 ztf = ( ztcn + ztc_f ) * ze3fr 394 ! ! swap of arrays 395 ptrab(ji,jj,jk,jn) = ztf ! tb <-- tn filtered 396 ptran(ji,jj,jk,jn) = ptraa(ji,jj,jk,jn) ! tn <-- ta 397 END DO 379 398 END DO 380 399 END DO -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/traqsr.F90
r1951 r2024 21 21 USE trc_oce ! share SMS/Ocean variables 22 22 USE trdmod_oce ! ocean variables trends 23 USE trd mod! ocean active tracers trends23 USE trdtra ! ocean active tracers trends 24 24 USE in_out_manager ! I/O manager 25 25 USE phycst ! physical constants … … 31 31 PRIVATE 32 32 33 PUBLIC tra_qsr ! routine called by step.F90 (ln_traqsr=T) 33 PUBLIC tra_qsr ! routine called by step.F90 (ln_traqsr=T) 34 PUBLIC tra_qsr_init ! routine called by opa.F90 34 35 35 36 ! !!* Namelist namtra_qsr: penetrative solar radiation … … 87 88 !! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 88 89 !!---------------------------------------------------------------------- 89 USE oce, ONLY : ztrdt => ua ! use ua as 3D workspace90 USE oce, ONLY : ztrds => va ! use va as 3D workspace91 90 !! 92 91 INTEGER, INTENT(in) :: kt ! ocean time-step … … 98 97 REAL(wp), DIMENSION(jpi,jpj) :: zekb, zekg, zekr ! 2D workspace 99 98 REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze0, ze1 , ze2, ze3, zea ! 3D workspace 99 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 100 100 !!---------------------------------------------------------------------- 101 101 … … 104 104 IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 105 105 IF(lwp) WRITE(numout,*) '~~~~~~~' 106 CALL tra_qsr_init107 106 IF( .NOT.ln_traqsr ) RETURN 108 107 ENDIF 109 108 110 109 IF( l_trdtra ) THEN ! Save ta and sa trends 111 ztrdt(:,:,:) = ta(:,:,:) 112 ztrds(:,:,:) = 0.e0 113 ENDIF 114 110 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 111 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = 0. 112 ENDIF 115 113 116 114 ! ! ============================================== ! … … 177 175 ! 178 176 DO jk = 1, nksr ! compute and add qsr trend to ta 179 t a(:,:,jk) = ta(:,:,jk) + ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) ) / fse3t(:,:,jk)177 tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) ) / fse3t(:,:,jk) 180 178 END DO 181 179 zea(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero … … 184 182 ELSE !* Constant Chlorophyll 185 183 DO jk = 1, nksr 186 t a(:,:,jk) = ta(:,:,jk) + etot3(:,:,jk) * qsr(:,:)184 tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + etot3(:,:,jk) * qsr(:,:) 187 185 END DO 188 186 ENDIF … … 196 194 DO jj = 2, jpjm1 197 195 DO ji = fs_2, fs_jpim1 ! vector opt. 198 t a(ji,jj,jk) = ta(ji,jj,jk) + etot3(ji,jj,jk) * qsr(ji,jj)196 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + etot3(ji,jj,jk) * qsr(ji,jj) 199 197 END DO 200 198 END DO … … 206 204 207 205 IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics 208 ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 209 CALL trd_mod( ztrdt, ztrds, jptra_trd_qsr, 'TRA', kt ) 206 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 207 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_qsr, ztrdt ) 208 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_qsr, ztrds ) 209 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 210 210 ENDIF 211 211 ! ! print mean trends (used for debugging) 212 IF(ln_ctl) CALL prt_ctl( tab3d_1=t a, clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' )212 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 213 213 ! 214 214 END SUBROUTINE tra_qsr -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trasbc.F90
r2004 r2024 17 17 USE phycst ! physical constant 18 18 USE traqsr ! solar radiation penetration 19 USE trdmod 20 USE trd mod_oce ! ocean variablestrends19 USE trdmod_oce ! ocean trends 20 USE trdtra ! ocean trends 21 21 USE in_out_manager ! I/O manager 22 22 USE prtctl ! Print control … … 100 100 !! - save the trend it in ttrd ('key_trdtra') 101 101 !!---------------------------------------------------------------------- 102 USE oce, ONLY : ztrdt => ua ! use ua as 3D workspace103 USE oce, ONLY : ztrds => va ! use va as 3D workspace104 102 !! 105 103 INTEGER, INTENT(in) :: kt ! ocean time-step index … … 110 108 REAL(wp) :: zsrau, zse3t, zdep ! temporary scalars, 1/density, 1/height of box, 1/height of effected water column 111 109 REAL(wp) :: zdheat, zdsalt ! total change of temperature and salinity 110 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 112 111 !!---------------------------------------------------------------------- 113 112 … … 123 122 #endif 124 123 125 IF( l_trdtra ) THEN !Save ta and sa trends126 ztrdt(:,:,:) = ta(:,:,:)127 ztrds(:,:,:) = sa(:,:,:)124 IF( l_trdtra ) THEN !* Save ta and sa trends 125 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 126 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsa(:,:,:,jp_sal) 128 127 ENDIF 129 128 … … 138 137 IF( lk_vvl) THEN 139 138 zta = ro0cpr * qns(ji,jj) * zse3t & ! temperature : heat flux 140 & - emp(ji,jj) * zsrau * t n(ji,jj,1) * zse3t ! & cooling/heating effet of EMP flux139 & - emp(ji,jj) * zsrau * tsn(ji,jj,1,jp_tem) * zse3t ! & cooling/heating effet of EMP flux 141 140 zsa = ( emps(ji,jj) - emp(ji,jj) ) & 142 & * zsrau * sn(ji,jj,1)* zse3t ! concent./dilut. effect due to sea-ice141 & * zsrau * tsn(ji,jj,1,jp_sal) * zse3t ! concent./dilut. effect due to sea-ice 143 142 ! melt/formation and (possibly) SSS restoration 144 143 ELSE 145 144 zta = ro0cpr * qns(ji,jj) * zse3t ! temperature : heat flux 146 zsa = emps(ji,jj) * zsrau * sn(ji,jj,1) * zse3t ! salinity : concent./dilut. effect145 zsa = emps(ji,jj) * zsrau * tsn(ji,jj,1,jp_sal) * zse3t ! salinity : concent./dilut. effect 147 146 ENDIF 148 t a(ji,jj,1) = ta(ji,jj,1) + zta! add the trend to the general tracer trend149 sa(ji,jj,1) = sa(ji,jj,1) + zsa147 tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zta ! add the trend to the general tracer trend 148 tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zsa 150 149 END DO 151 150 END DO 152 151 153 152 IF ( ln_rnf .AND. ln_rnf_att ) THEN 154 ! Concentration / dilution effect on (t,s) due to river runoff155 DO jj =1,jpj156 DO ji =1,jpi157 rnf_dep(ji,jj) =0158 DO jk =1,rnf_mod_dep(ji,jj) ! recalculates rnf_dep to be the depth159 rnf_dep(ji,jj) =rnf_dep(ji,jj)+fse3t(ji,jj,jk) ! in metres to the bottom of the relevant grid box153 ! Concentration / dilution effect on (t,s) due to river runoff 154 DO jj = 1, jpj 155 DO ji = 1, jpi 156 rnf_dep(ji,jj) = 0. 157 DO jk = 1, rnf_mod_dep(ji,jj) ! recalculates rnf_dep to be the depth 158 rnf_dep(ji,jj) = rnf_dep(ji,jj) + fse3t(ji,jj,jk) ! in metres to the bottom of the relevant grid box 160 159 ENDDO 161 160 zdep = 1. / rnf_dep(ji,jj) 162 161 zse3t= 1. / fse3t(ji,jj,1) 163 IF ( rnf_tmp(ji,jj) == -999 ) rnf_tmp(ji,jj)=tn(ji,jj,1) ! if not specified set runoff temp to be sst 164 165 IF ( rnf(ji,jj) .gt. 0.0 ) THEN 166 167 IF( lk_vvl) THEN 168 !!!indirect flux, concentration or dilution effect 169 !!!force a dilution effect in all levels; 170 zdheat=0.0 171 zdsalt=0.0 172 DO jk=1, rnf_mod_dep(ji,jj) 173 zta = -tn(ji,jj,jk) * rnf(ji,jj) * zsrau * zdep 174 zsa = -sn(ji,jj,jk) * rnf(ji,jj) * zsrau * zdep 175 ta(ji,jj,jk)=ta(ji,jj,jk)+zta 176 sa(ji,jj,jk)=sa(ji,jj,jk)+zsa 177 zdheat=zdheat+zta*fse3t(ji,jj,jk) 178 zdsalt=zdsalt+zsa*fse3t(ji,jj,jk) 162 IF ( rnf_tmp(ji,jj) == -999 ) rnf_tmp(ji,jj) = tsn(ji,jj,1,jp_tem) ! if not specified set runoff temp to be sst 163 164 IF ( rnf(ji,jj) > 0.0 ) THEN 165 166 IF( lk_vvl ) THEN 167 ! indirect flux, concentration or dilution effect : force a dilution effect in all levels 168 zdheat = 0.0 169 zdsalt = 0.0 170 DO jk = 1, rnf_mod_dep(ji,jj) 171 zta = -tsn(ji,jj,jk,jp_tem) * rnf(ji,jj) * zsrau * zdep 172 zsa = -tsn(ji,jj,jk,jp_sal) * rnf(ji,jj) * zsrau * zdep 173 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta ! add the trend to the general tracer trend 174 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 175 zdheat = zdheat + zta * fse3t(ji,jj,jk) 176 zdsalt = zdsalt + zsa * fse3t(ji,jj,jk) 179 177 ENDDO 180 ! !!negate this total change in heat and salt content from top level181 zta =-zdheat*zse3t182 zsa =-zdsalt*zse3t183 t a(ji,jj,1)=ta(ji,jj,1)+zta184 sa(ji,jj,1)=sa(ji,jj,1)+zsa178 ! negate this total change in heat and salt content from top level 179 zta = -zdheat * zse3t 180 zsa = -zdsalt * zse3t 181 tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zta ! add the trend to the general tracer trend 182 tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zsa 185 183 186 ! !!direct flux184 ! direct flux 187 185 zta = rnf_tmp(ji,jj) * rnf(ji,jj) * zsrau * zdep 188 186 zsa = rnf_sal(ji,jj) * rnf(ji,jj) * zsrau * zdep 189 187 190 DO jk =1, rnf_mod_dep(ji,jj)191 t a(ji,jj,jk) = ta(ji,jj,jk) + zta192 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa188 DO jk = 1, rnf_mod_dep(ji,jj) 189 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta ! add the trend to the general tracer trend 190 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 193 191 ENDDO 194 192 195 193 ELSE 196 DO jk =1, rnf_mod_dep(ji,jj)197 zta = ( rnf_tmp(ji,jj) -tn(ji,jj,jk) ) * rnf(ji,jj) * zsrau * zdep198 zsa = ( rnf_sal(ji,jj) -sn(ji,jj,jk) ) * rnf(ji,jj) * zsrau * zdep199 t a(ji,jj,jk) = ta(ji,jj,jk) + zta200 sa(ji,jj,jk) = sa(ji,jj,jk) + zsa194 DO jk = 1, rnf_mod_dep(ji,jj) 195 zta = ( rnf_tmp(ji,jj) - tsn(ji,jj,jk,jp_tem) ) * rnf(ji,jj) * zsrau * zdep 196 zsa = ( rnf_sal(ji,jj) - tsn(ji,jj,jk,jp_sal) ) * rnf(ji,jj) * zsrau * zdep 197 tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + zta ! add the trend to the general tracer trend 198 tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + zsa 201 199 ENDDO 202 200 ENDIF 203 201 204 ELSE IF (rnf(ji,jj) .lt. 0.) THEN !! for use in baltic when flow is out of domain, want no change in temp and sal205 206 IF( lk_vvl ) THEN207 ! calculate automatic adjustment to sal and temp due to dilution/concentraion effect208 zata = t n(ji,jj,1) * rnf(ji,jj) * zsrau * zse3t209 zasa = sn(ji,jj,1) * rnf(ji,jj) * zsrau * zse3t210 t a(ji,jj,1)=ta(ji,jj,1) + zata211 sa(ji,jj,1)=sa(ji,jj,1) + zasa202 ELSE IF( rnf(ji,jj) > 0.) THEN ! for use in baltic when flow is out of domain, want no change in temp and sal 203 204 IF( lk_vvl ) THEN 205 ! calculate automatic adjustment to sal and temp due to dilution/concentraion effect 206 zata = tsn(ji,jj,1,jp_tem) * rnf(ji,jj) * zsrau * zse3t 207 zasa = tsn(ji,jj,1,jp_sal) * rnf(ji,jj) * zsrau * zse3t 208 tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zata ! add the trend to the general tracer trend 209 tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zasa 212 210 ENDIF 213 211 … … 226 224 #endif 227 225 IF( lk_vvl) THEN 228 zta = rnf(ji,jj) * zsrau * tn(ji,jj,1) * zse3t ! & cooling/heating effect of runoff229 zsa = 0.e0 ! No salinity concent./dilut. effect226 zta = rnf(ji,jj) * zsrau * tsn(ji,jj,1,jp_tem) * zse3t ! & cooling/heating effect of runoff 227 zsa = 0.e0 ! No salinity concent./dilut. effect 230 228 ELSE 231 zta = 0.0 ! temperature : heat flux232 zsa = - rnf(ji,jj) * zsrau * sn(ji,jj,1) * zse3t ! salinity : concent./dilut. effect229 zta = 0.0 ! temperature : heat flux 230 zsa = - rnf(ji,jj) * zsrau * tsn(ji,jj,1,jp_sal) * zse3t ! salinity : concent./dilut. effect 233 231 ENDIF 234 t a(ji,jj,1) = ta(ji,jj,1) + zta! add the trend to the general tracer trend235 sa(ji,jj,1) = sa(ji,jj,1) + zsa232 tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + zta ! add the trend to the general tracer trend 233 tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + zsa 236 234 END DO 237 235 END DO … … 239 237 ENDIF 240 238 241 IF( l_trdtra ) THEN ! save the sbc trends for diagnostic 242 ztrdt(:,:,:) = ta(:,:,:) - ztrdt(:,:,:) 243 ztrds(:,:,:) = sa(:,:,:) - ztrds(:,:,:) 244 CALL trd_mod(ztrdt, ztrds, jptra_trd_nsr, 'TRA', kt) 239 IF( l_trdtra ) THEN ! save the horizontal diffusive trends for further diagnostics 240 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 241 ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 242 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_nsr, ztrdt ) 243 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_nsr, ztrds ) 244 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 245 245 ENDIF 246 246 ! 247 IF(ln_ctl) CALL prt_ctl( tab3d_1=t a, clinfo1=' sbc - Ta: ', mask1=tmask, &248 & tab3d_2= sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )247 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' sbc - Ta: ', mask1=tmask, & 248 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 249 249 ! 250 250 END SUBROUTINE tra_sbc -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trazdf.F90
r1533 r2024 4 4 !! Ocean active tracers: vertical component of the tracer mixing trend 5 5 !!============================================================================== 6 !! History : 9.0 ! 05-11 (G. Madec) Original code 6 !! History : 9.0 ! 2005-11 (G. Madec) Original code 7 !! NEMO 3.0 ! 2008-01 (C. Ethe, G. Madec) merge TRC-TRA 7 8 !!---------------------------------------------------------------------- 8 9 … … 21 22 22 23 USE ldftra_oce ! ocean active tracers: lateral physics 23 USE trdmod ! ocean active tracers trends24 USE trd mod_oce ! ocean variables trends24 USE trdmod_oce ! ocean active tracers: lateral physics 25 USE trdtra ! ocean tracers trends 25 26 USE in_out_manager ! I/O manager 26 27 USE prtctl ! Print control … … 33 34 PRIVATE 34 35 35 PUBLIC tra_zdf ! routine called by step.F90 36 PUBLIC tra_zdf ! routine called by step.F90 37 PUBLIC tra_zdf_init ! routine called by opa.F90 36 38 37 39 INTEGER :: nzdf = 0 ! type vertical diffusion algorithm used 38 40 ! ! defined from ln_zdf... namlist logicals) 39 40 41 REAL(wp), DIMENSION(jpk) :: r2dt ! vertical profile time-step, = 2 rdttra 41 42 ! ! except at nit000 (=rdttra) if neuler=0 … … 62 63 63 64 INTEGER :: jk ! Dummy loop indices 64 REAL(wp), DIMENSION( jpi,jpj,jpk):: ztrdt, ztrds ! 3D workspace65 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace 65 66 !!--------------------------------------------------------------------- 66 67 IF( kt == nit000 ) CALL zdf_ctl ! initialisation & control of options68 67 69 68 ! ! set time step … … 74 73 ENDIF 75 74 76 IF( l_trdtra ) THEN ! temporary save ofta and sa trends77 ztrdt(:,:,:) = ta(:,:,:)78 ztrds(:,:,:) = sa(:,:,:)75 IF( l_trdtra ) THEN !* Save ta and sa trends 76 ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 77 ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsa(:,:,:,jp_sal) 79 78 ENDIF 80 79 81 80 SELECT CASE ( nzdf ) ! compute lateral mixing trend and add it to the general trend 81 CASE ( 0 ) ; CALL tra_zdf_exp( kt , 'TRA', r2dt, nn_zdfexp, & 82 & tsb, tsa , jpts ) ! explicit scheme 83 CASE ( 1 ) ; CALL tra_zdf_imp( kt , 'TRA', r2dt, & 84 & tsb, tsa , jpts ) ! implicit scheme 82 85 CASE ( -1 ) ! esopa: test all possibility with control print 83 CALL tra_zdf_exp ( kt, r2dt ) 84 CALL prt_ctl( tab3d_1=ta, clinfo1=' zdf0 - Ta: ', mask1=tmask, & 85 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 86 CALL tra_zdf_imp ( kt, r2dt ) 87 CALL prt_ctl( tab3d_1=ta, clinfo1=' zdf1 - Ta: ', mask1=tmask, & 88 & tab3d_2=sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 89 90 CASE ( 0 ) ! explicit scheme 91 CALL tra_zdf_exp ( kt, r2dt ) 92 93 CASE ( 1 ) ! implicit scheme 94 CALL tra_zdf_imp ( kt, r2dt ) 95 86 CALL tra_zdf_exp( kt , 'TRA', r2dt, nn_zdfexp, & 87 & tsb, tsa , jpts ) 88 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf0 - Ta: ', mask1=tmask, & 89 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 90 CALL tra_zdf_imp( kt , 'TRA', r2dt, & 91 & tsb, tsa , jpts ) 92 CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf1 - Ta: ', mask1=tmask, & 93 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 96 94 END SELECT 97 95 98 96 IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics 99 97 DO jk = 1, jpkm1 100 ztrdt(:,:,jk) = ( ( t a(:,:,jk) - tb(:,:,jk) ) / r2dt(jk) ) - ztrdt(:,:,jk)101 ztrds(:,:,jk) = ( ( sa(:,:,jk) - sb(:,:,jk) ) / r2dt(jk) ) - ztrds(:,:,jk)98 ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dt(jk) ) - ztrdt(:,:,jk) 99 ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dt(jk) ) - ztrds(:,:,jk) 102 100 END DO 103 CALL trd_mod( ztrdt, ztrds, jptra_trd_zdf, 'TRA', kt ) 101 CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_zdf, ztrdt ) 102 CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_zdf, ztrds ) 103 DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) 104 104 ENDIF 105 105 106 106 ! ! print mean trends (used for debugging) 107 IF(ln_ctl) CALL prt_ctl( tab3d_1=t a, clinfo1=' zdf - Ta: ', mask1=tmask, &108 & tab3d_2= sa, clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )107 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf - Ta: ', mask1=tmask, & 108 & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) 109 109 110 110 END SUBROUTINE tra_zdf 111 111 112 112 113 SUBROUTINE zdf_ctl113 SUBROUTINE tra_zdf_init 114 114 !!---------------------------------------------------------------------- 115 !! *** ROUTINE zdf_ctl***115 !! *** ROUTINE tra_zdf_init *** 116 116 !! 117 117 !! ** Purpose : Choose the vertical mixing scheme … … 153 153 IF(lwp) THEN 154 154 WRITE(numout,*) 155 WRITE(numout,*) 'tra :zdf_ctl: vertical tracer physics scheme'155 WRITE(numout,*) 'tra_zdf_init : vertical tracer physics scheme' 156 156 WRITE(numout,*) '~~~~~~~~~~~' 157 157 IF( nzdf == -1 ) WRITE(numout,*) ' ESOPA test All scheme used' … … 160 160 ENDIF 161 161 162 END SUBROUTINE zdf_ctl162 END SUBROUTINE tra_zdf_init 163 163 164 164 !!============================================================================== -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trazdf_exp.F90
r1537 r2024 2 2 !!============================================================================== 3 3 !! *** MODULE trazdf_exp *** 4 !! Ocean activetracers: vertical component of the tracer mixing trend using5 !! 4 !! Ocean tracers: vertical component of the tracer mixing trend using 5 !! a split-explicit time-stepping 6 6 !!============================================================================== 7 7 !! History : OPA ! 1990-10 (B. Blanke) Original code … … 16 16 !! - ! 2005-11 (G. Madec) New organisation 17 17 !! 3.0 ! 2008-04 (G. Madec) leap-frog time stepping done in trazdf 18 !! 3.3 ! 2010-06 (C. Ethe, G. Madec) Merge TRA-TRC 18 19 !!---------------------------------------------------------------------- 19 20 … … 24 25 USE oce ! ocean dynamics and active tracers 25 26 USE dom_oce ! ocean space and time domain 26 USE domvvl ! variablevolume levels 27 USE trdmod ! ocean active tracers trends 28 USE trdmod_oce ! ocean variables trends 27 USE domvvl ! variable volume levels 29 28 USE zdf_oce ! ocean vertical physics 30 29 USE zdfddm ! ocean vertical physics: double diffusion 31 30 USE in_out_manager ! I/O manager 32 USE prtctl ! Print control33 31 34 32 IMPLICIT NONE … … 49 47 CONTAINS 50 48 51 SUBROUTINE tra_zdf_exp( kt, p2dt ) 49 SUBROUTINE tra_zdf_exp( kt , cdtype, p2dt, kn_zdfexp, & 50 & ptrab , ptraa , kjpt ) 52 51 !!---------------------------------------------------------------------- 53 52 !! *** ROUTINE tra_zdf_exp *** … … 58 57 !! ** Method : - The after tracer fields due to the vertical diffusion 59 58 !! of tracers alone is given by: 60 !! zwx = tb + p2dt difft61 !! where difft = dz( avt dz( tb) ) = 1/e3t dk+1( avt/e3w dk(tb) )62 !! (if lk_zdfddm=T use avs on salinity instead of avt)59 !! zwx = ptrab + p2dt difft 60 !! where difft = dz( avt dz(ptrab) ) = 1/e3t dk+1( avt/e3w dk(ptrab) ) 61 !! (if lk_zdfddm=T use avs on salinity and passive tracers instead of avt) 63 62 !! difft is evaluated with an Euler split-explit scheme using a 64 63 !! no flux boundary condition at both surface and bottomi boundaries. … … 66 65 !! - the after tracer fields due to the whole trend is 67 66 !! obtained in leap-frog environment by : 68 !! ta = zwx + p2dt ta67 !! ptraa = zwx + p2dt ptraa 69 68 !! - in case of variable level thickness (lk_vvl=T) the 70 69 !! the leap-frog is applied on thickness weighted tracer. That is: 71 !! ta = [ tb*e3tb + e3tn*( zwx - tb + p2dt ta ) ] / e3tn70 !! ptraa = [ ptrab*e3tb + e3tn*( zwx - ptrab + p2dt ptraa ) ] / e3tn 72 71 !! 73 !! ** Action : - after tracer fields (ta,sa)72 !! ** Action : - after tracer fields pta 74 73 !!--------------------------------------------------------------------- 75 INTEGER , INTENT(in) :: kt ! ocean time-step index 76 REAL(wp), INTENT(in), DIMENSION(jpk) :: p2dt ! vertical profile of tracer time-step 77 !! 78 INTEGER :: ji, jj, jk, jl ! dummy loop indices 79 REAL(wp) :: zlavmr, zave3r, ze3tr ! temporary scalars 80 REAL(wp) :: zta, zsa, ze3tb ! temporary scalars 81 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zwy, zwz, zww ! 3D workspace 74 !! * Arguments 75 INTEGER , INTENT(in ) :: kt ! ocean time-step index 76 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 77 INTEGER , INTENT(in ) :: kjpt ! number of tracers 78 INTEGER , INTENT(in ) :: kn_zdfexp ! number of sub-time step 79 REAL(wp) , INTENT(in ), DIMENSION(jpk) :: p2dt ! vertical profile of tracer time-step 80 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 81 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 82 !! * Local declarations 83 INTEGER :: ji, jj, jk, jn, jl ! dummy loop indices 84 REAL(wp) :: zlavmr, zave3r, ze3tr ! temporary scalars 85 REAL(wp) :: ztra, ze3tb ! temporary scalars 86 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwx, zwy ! 3D workspace 82 87 !!--------------------------------------------------------------------- 83 88 … … 90 95 ! Initializations 91 96 ! --------------- 92 zlavmr = 1. / float( nn_zdfexp ) ! Local constant97 zlavmr = 1. / float( kn_zdfexp ) ! Local constant 93 98 ! 94 zwy(:,:, 1 ) = 0.e0 ; zww(:,:, 1 ) = 0.e0 ! surface boundary conditions: no flux95 zwy(:,:,jpk) = 0.e0 ; zww(:,:,jpk) = 0.e0 ! bottom boundary conditions: no flux96 99 ! 97 zwx(:,:,:) = tb(:,:,:) ; zwz(:,:,:) = sb(:,:,:) ! zwx and zwz arrays set to before tracer values 100 DO jn = 1, kjpt 101 ! 102 zwy(:,:, 1 ) = 0.e0 ! surface boundary conditions: no flux 103 zwy(:,:,jpk) = 0.e0 ! bottom boundary conditions: no flux 104 ! 105 zwx(:,:,:) = ptrab(:,:,:,jn) ! zwx array set to before tracer values 98 106 99 ! Split-explicit loop (after tracer due to the vertical diffusion alone) 100 ! ------------------- 101 ! 102 DO jl = 1, nn_zdfexp 103 ! ! first vertical derivative 104 DO jk = 2, jpk 105 DO jj = 2, jpjm1 106 DO ji = fs_2, fs_jpim1 ! vector opt. 107 zave3r = 1.e0 / fse3w_n(ji,jj,jk) 108 zwy(ji,jj,jk) = avt(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 109 zww(ji,jj,jk) = fsavs(ji,jj,jk) * ( zwz(ji,jj,jk-1) - zwz(ji,jj,jk) ) * zave3r 107 ! Split-explicit loop (after tracer due to the vertical diffusion alone) 108 ! ------------------- 109 ! 110 DO jl = 1, kn_zdfexp 111 ! ! first vertical derivative 112 DO jk = 2, jpk 113 DO jj = 2, jpjm1 114 DO ji = fs_2, fs_jpim1 ! vector opt. 115 zave3r = 1.e0 / fse3w_n(ji,jj,jk) 116 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN ! temperature : use of avt 117 zwy(ji,jj,jk) = avt(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 118 ELSE ! salinity or pass. tracer : use of avs 119 zwy(ji,jj,jk) = fsavs(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) * zave3r 120 END IF 121 END DO 110 122 END DO 111 123 END DO 112 END DO 113 ! 114 DO jk = 1, jpkm1 ! second vertical derivative ==> tracer at kt+l*2*rdt/nn_zdfexp 115 DO jj = 2, jpjm1 116 DO ji = fs_2, fs_jpim1 ! vector opt. 117 ze3tr = zlavmr / fse3t_n(ji,jj,jk) 118 zwx(ji,jj,jk) = zwx(ji,jj,jk) + p2dt(jk) * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) * ze3tr 119 zwz(ji,jj,jk) = zwz(ji,jj,jk) + p2dt(jk) * ( zww(ji,jj,jk) - zww(ji,jj,jk+1) ) * ze3tr 124 ! 125 DO jk = 1, jpkm1 ! second vertical derivative ==> tracer at kt+l*2*rdt/nn_zdfexp 126 DO jj = 2, jpjm1 127 DO ji = fs_2, fs_jpim1 ! vector opt. 128 ze3tr = zlavmr / fse3t_n(ji,jj,jk) 129 zwx(ji,jj,jk) = zwx(ji,jj,jk) + p2dt(jk) * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) * ze3tr 130 END DO 120 131 END DO 121 132 END DO 133 ! 122 134 END DO 135 136 ! After tracer due to all trends 137 ! ------------------------------ 138 IF( lk_vvl ) THEN ! variable level thickness : leap-frog on tracer*e3t 139 DO jk = 1, jpkm1 140 DO jj = 2, jpjm1 141 DO ji = fs_2, fs_jpim1 ! vector opt. 142 ze3tb = fse3t_b(ji,jj,jk) / fse3t(ji,jj,jk) ! before e3t 143 ztra = zwx(ji,jj,jk) - ptrab(ji,jj,jk,jn) + p2dt(jk) * ptraa(ji,jj,jk,jn) ! total trends * 2*rdt 144 ptraa(ji,jj,jk,jn) = ( ze3tb * ptrab(ji,jj,jk,jn) + ztra ) * tmask(ji,jj,jk) 145 END DO 146 END DO 147 END DO 148 ELSE ! fixed level thickness : leap-frog on tracers 149 DO jk = 1, jpkm1 150 DO jj = 2, jpjm1 151 DO ji = fs_2, fs_jpim1 ! vector opt. 152 ptraa(ji,jj,jk,jn) = ( zwx(ji,jj,jk) + p2dt(jk) * ptraa(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 153 END DO 154 END DO 155 END DO 156 ENDIF 123 157 ! 124 158 END DO 125 126 ! After tracer due to all trends127 ! ------------------------------128 IF( lk_vvl ) THEN ! variable level thickness : leap-frog on tracer*e3t129 DO jk = 1, jpkm1130 DO jj = 2, jpjm1131 DO ji = fs_2, fs_jpim1 ! vector opt.132 ze3tb = fse3t_b(ji,jj,jk) / fse3t(ji,jj,jk) ! before e3t133 zta = zwx(ji,jj,jk) - tb(ji,jj,jk) + p2dt(jk) * ta(ji,jj,jk) ! total trends * 2*rdt134 zsa = zwz(ji,jj,jk) - sb(ji,jj,jk) + p2dt(jk) * sa(ji,jj,jk)135 ta(ji,jj,jk) = ( ze3tb * tb(ji,jj,jk) + zta ) * tmask(ji,jj,jk)136 sa(ji,jj,jk) = ( ze3tb * sb(ji,jj,jk) + zsa ) * tmask(ji,jj,jk)137 END DO138 END DO139 END DO140 ELSE ! fixed level thickness : leap-frog on tracers141 DO jk = 1, jpkm1142 DO jj = 2, jpjm1143 DO ji = fs_2, fs_jpim1 ! vector opt.144 ta(ji,jj,jk) = ( zwx(ji,jj,jk) + p2dt(jk) * ta(ji,jj,jk) ) * tmask(ji,jj,jk)145 sa(ji,jj,jk) = ( zwz(ji,jj,jk) + p2dt(jk) * sa(ji,jj,jk) ) * tmask(ji,jj,jk)146 END DO147 END DO148 END DO149 ENDIF150 159 ! 151 160 END SUBROUTINE tra_zdf_exp -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/trazdf_imp.F90
r1517 r2024 2 2 !!====================================================================== 3 3 !! *** MODULE trazdf_imp *** 4 !! Ocean activetracers: vertical component of the tracer mixing trend4 !! Ocean tracers: vertical component of the tracer mixing trend 5 5 !!====================================================================== 6 6 !! History : OPA ! 1990-10 (B. Blanke) Original code … … 14 14 !! 2.0 ! 2006-11 (G. Madec) New step reorganisation 15 15 !! 3.2 ! 2009-03 (G. Madec) heat and salt content trends 16 !! 3.3 ! 2010-06 (C. Ethe, G. Madec) Merge TRA-TRC 16 17 !!---------------------------------------------------------------------- 17 18 … … 25 26 USE ldftra_oce ! ocean active tracers: lateral physics 26 27 USE ldfslp ! lateral physics: slope of diffusion 27 USE trdmod ! ocean active tracers trends28 USE trdmod_oce ! ocean variables trends29 28 USE zdfddm ! ocean vertical physics: double diffusion 30 29 USE in_out_manager ! I/O manager 31 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 32 USE prtctl ! Print control33 31 USE domvvl ! variable volume 34 32 USE ldftra ! lateral mixing type … … 50 48 !!---------------------------------------------------------------------- 51 49 CONTAINS 52 53 SUBROUTINE tra_zdf_imp( kt, p2dt ) 50 51 SUBROUTINE tra_zdf_imp( kt , cdtype, p2dt, & 52 & ptrab , ptraa , kjpt ) 54 53 !!---------------------------------------------------------------------- 55 54 !! *** ROUTINE tra_zdf_imp *** … … 71 70 !! associated with the lateral mixing, through the 72 71 !! update of avt) 73 !! The vertical diffusion of t racers (t & s)is given by:72 !! The vertical diffusion of the tracer t is given by: 74 73 !! difft = dz( avt dz(t) ) = 1/e3t dk+1( avt/e3w dk(t) ) 75 74 !! It is computed using a backward time scheme (t=ta). … … 78 77 !! Add this trend to the general trend ta,sa : 79 78 !! ta = ta + dz( avt dz(t) ) 80 !! (sa = sa + dz( avs dz(t) ) if lk_zdfddm=T ) 79 !! if lk_zdfddm=T, use avs for salinity or for passive tracers 80 !! (sa = sa + dz( avs dz(t) ) 81 81 !! 82 82 !! Third part: recover avt resulting from the vertical physics 83 83 !! ========== alone, for further diagnostics (for example to 84 84 !! compute the turbocline depth in zdfmxl.F90). 85 !! avt = zavt85 !! if lk_zdfddm=T, use avt = zavt 86 86 !! (avs = zavs if lk_zdfddm=T ) 87 87 !! 88 !! ** Action : - Update (ta ,sa) with before vertical diffusion trend88 !! ** Action : - Update (ta) with before vertical diffusion trend 89 89 !! 90 90 !!--------------------------------------------------------------------- 91 !! * Modules used 91 92 USE oce , ONLY : zwd => ua ! ua used as workspace 92 93 USE oce , ONLY : zws => va ! va - - 93 !! 94 INTEGER , INTENT(in) :: kt ! ocean time-step index 95 REAL(wp), DIMENSION(jpk), INTENT(in) :: p2dt ! vertical profile of tracer time-step 96 !! 97 INTEGER :: ji, jj, jk ! dummy loop indices 98 REAL(wp) :: zavi, zrhs, znvvl ! temporary scalars 99 REAL(wp) :: ze3tb, ze3tn, ze3ta ! variable vertical scale factors 100 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwt, zavsi ! workspace arrays 94 !! * Arguments 95 INTEGER , INTENT(in ) :: kt ! ocean time-step index 96 CHARACTER(len=3), INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) 97 INTEGER , INTENT(in ) :: kjpt ! number of tracers 98 REAL(wp) , INTENT(in ), DIMENSION(jpk) :: p2dt ! vertical profile of tracer time-step 99 REAL(wp) , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) :: ptrab ! before and now tracer fields 100 REAL(wp) , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt) :: ptraa ! tracer trend 101 !! 102 INTEGER :: ji, jj, jk, jn ! dummy loop indices 103 REAL(wp) :: zavi, zrhs, znvvl ! temporary scalars 104 REAL(wp) :: ze3tb, ze3tn, ze3ta ! variable vertical scale factors 105 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwt ! workspace arrays 101 106 !!--------------------------------------------------------------------- 102 107 … … 107 112 zavi = 0.e0 ! avoid warning at compilation phase when lk_ldfslp=F 108 113 ENDIF 109 114 ! 110 115 ! I. Local initialization 111 116 ! ----------------------- 112 zwd (1,:, : ) = 0.e0 ; zwd (jpi,:,:) = 0.e0 113 zws (1,:, : ) = 0.e0 ; zws (jpi,:,:) = 0.e0 114 zwi (1,:, : ) = 0.e0 ; zwi (jpi,:,:) = 0.e0 115 zwt (1,:, : ) = 0.e0 ; zwt (jpi,:,:) = 0.e0 116 zavsi(1,:, : ) = 0.e0 ; zavsi(jpi,:,:) = 0.e0 117 zwt (:,:,jpk) = 0.e0 ; zwt ( : ,:,1) = 0.e0 118 zavsi(:,:,jpk) = 0.e0 ; zavsi( : ,:,1) = 0.e0 117 zwd(1,:, : ) = 0.e0 ; zwd(jpi,:,:) = 0.e0 118 zws(1,:, : ) = 0.e0 ; zws(jpi,:,:) = 0.e0 119 zwi(1,:, : ) = 0.e0 ; zwi(jpi,:,:) = 0.e0 120 zwt(1,:, : ) = 0.e0 ; zwt(jpi,:,:) = 0.e0 121 zwt(:,:,jpk) = 0.e0 ; zwt( : ,:,1) = 0.e0 119 122 120 123 ! I.1 Variable volume : to take into account vertical variable vertical scale factors … … 130 133 ! dk[ avt dk[ (t,s) ] ] diffusive trends 131 134 132 135 ! 133 136 ! II.0 Matrix construction 134 137 ! ------------------------ 135 138 DO jn = 1, kjpt 139 ! 140 ! Matrix construction 141 ! ------------------------ 142 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 136 143 #if defined key_ldfslp 137 ! update and save of avt (and avs if double diffusive mixing) 138 IF( l_traldf_rot ) THEN 139 DO jk = 2, jpkm1 144 ! update and save of avt (and avs if double diffusive mixing) 145 IF( l_traldf_rot ) THEN 146 DO jk = 2, jpkm1 147 DO jj = 2, jpjm1 148 DO ji = fs_2, fs_jpim1 ! vector opt. 149 zavi = fsahtw(ji,jj,jk) & ! vertical mixing coef. due to lateral mixing 150 & * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & 151 & + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) 152 zwt(ji,jj,jk) = avt(ji,jj,jk) + zavi ! zwt=avt+zavi (total vertical mixing coef. on temperature) 153 END DO 154 END DO 155 END DO 156 ELSE ! no rotation but key_ldfslp defined 157 zwt (:,:,:) = avt(:,:,:) 158 ENDIF 159 #else 160 ! No isopycnal diffusion 161 zwt(:,:,:) = avt(:,:,:) 162 #endif 163 ! Diagonal, inferior, superior (including the bottom boundary condition via avt masked) 164 DO jk = 1, jpkm1 165 DO jj = 2, jpjm1 166 DO ji = fs_2, fs_jpim1 ! vector opt. 167 ze3ta = ( 1. - znvvl ) + znvvl * fse3t_a(ji,jj,jk) ! after scale factor at T-point 168 ze3tn = znvvl + ( 1. - znvvl ) * fse3t_n(ji,jj,jk) ! now scale factor at T-point 169 zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / ( ze3tn * fse3w(ji,jj,jk ) ) 170 zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 171 zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 172 END DO 173 END DO 174 END DO 175 ! Surface boudary conditions 140 176 DO jj = 2, jpjm1 141 177 DO ji = fs_2, fs_jpim1 ! vector opt. 142 zavi = fsahtw(ji,jj,jk) & ! vertical mixing coef. due to lateral mixing 143 & * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & 144 & + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) 145 zwt(ji,jj,jk) = avt(ji,jj,jk) + zavi ! zwt=avt+zavi (total vertical mixing coef. on temperature) 146 # if defined key_zdfddm 147 zavsi(ji,jj,jk) = fsavs(ji,jj,jk) + zavi ! dd mixing: zavsi = total vertical mixing coef. on salinity 148 # endif 149 END DO 150 END DO 151 END DO 152 ELSE ! no rotation but key_ldfslp defined 153 zwt (:,:,:) = avt(:,:,:) 154 # if defined key_zdfddm 155 zavsi(:,:,:) = avs(:,:,:) ! avs /= avt (double diffusion mixing) 156 # endif 157 ENDIF 178 ze3ta = ( 1. - znvvl ) + znvvl * fse3t_a(ji,jj,1) ! after scale factor at T-point 179 zwi(ji,jj,1) = 0.e0 180 zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 181 END DO 182 END DO 183 ! 184 ELSE IF( ( cdtype == 'TRA' .AND. jn == jp_sal ) .OR. ( cdtype == 'TRC' .AND. jn == 1 ) ) THEN 185 #if defined key_ldfslp 186 ! update and save of avt (and avs if double diffusive mixing) 187 IF( l_traldf_rot ) THEN 188 DO jk = 2, jpkm1 189 DO jj = 2, jpjm1 190 DO ji = fs_2, fs_jpim1 ! vector opt. 191 zavi = fsahtw(ji,jj,jk) & ! vertical mixing coef. due to lateral mixing 192 & * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & 193 & + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) 194 zwt(ji,jj,jk) = fsavs(ji,jj,jk) + zavi ! zwt=avt+zavi (total vertical mixing coef. on temperature) 195 END DO 196 END DO 197 END DO 198 ELSE ! no rotation but key_ldfslp defined 199 zwt (:,:,:) = fsavs(:,:,:) 200 ENDIF 158 201 #else 159 ! No isopycnal diffusion 160 zwt(:,:,:) = avt(:,:,:) 161 # if defined key_zdfddm 162 zavsi(:,:,:) = avs(:,:,:) 163 # endif 164 202 ! No isopycnal diffusion 203 zwt(:,:,:) = fsavs(:,:,:) 165 204 #endif 166 167 ! Diagonal, inferior, superior (including the bottom boundary condition via avt masked) 168 DO jk = 1, jpkm1 169 DO jj = 2, jpjm1 170 DO ji = fs_2, fs_jpim1 ! vector opt. 171 ze3ta = ( 1. - znvvl ) & ! after scale factor at T-point 172 & + znvvl * fse3t_a(ji,jj,jk) 173 ze3tn = znvvl & ! now scale factor at T-point 174 & + ( 1. - znvvl ) * fse3t_n(ji,jj,jk) 175 zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / ( ze3tn * fse3w(ji,jj,jk ) ) 176 zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 177 zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 178 END DO 179 END DO 180 END DO 181 182 ! Surface boudary conditions 183 DO jj = 2, jpjm1 184 DO ji = fs_2, fs_jpim1 ! vector opt. 185 ze3ta = ( 1. - znvvl ) & ! after scale factor at T-point 186 & + znvvl * fse3t_a(ji,jj,1) 187 zwi(ji,jj,1) = 0.e0 188 zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 189 END DO 190 END DO 191 192 193 ! II.1. Vertical diffusion on t 194 ! --------------------------- 195 196 !! Matrix inversion from the first level 197 !!---------------------------------------------------------------------- 198 ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) 199 ! 200 ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) 201 ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) 202 ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) 203 ! ( ... )( ... ) ( ... ) 204 ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) 205 ! 206 ! m is decomposed in the product of an upper and lower triangular matrix 207 ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi 208 ! The second member is in 2d array zwy 209 ! The solution is in 2d array zwx 210 ! The 3d arry zwt is a work space array 211 ! zwy is used and then used as a work space array : its value is modified! 212 213 ! first recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) 214 DO jj = 2, jpjm1 215 DO ji = fs_2, fs_jpim1 216 zwt(ji,jj,1) = zwd(ji,jj,1) 217 END DO 218 END DO 219 DO jk = 2, jpkm1 205 ! Diagonal, inferior, superior (including the bottom boundary condition via avt masked) 206 DO jk = 1, jpkm1 207 DO jj = 2, jpjm1 208 DO ji = fs_2, fs_jpim1 ! vector opt. 209 ze3ta = ( 1. - znvvl ) + znvvl * fse3t_a(ji,jj,jk) ! after scale factor at T-point 210 ze3tn = znvvl + ( 1. - znvvl ) * fse3t_n(ji,jj,jk) ! now scale factor at T-point 211 zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / ( ze3tn * fse3w(ji,jj,jk ) ) 212 zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 213 zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 214 END DO 215 END DO 216 END DO 217 ! Surface boudary conditions 218 DO jj = 2, jpjm1 219 DO ji = fs_2, fs_jpim1 ! vector opt. 220 ze3ta = ( 1. - znvvl ) + znvvl * fse3t_a(ji,jj,1) ! after scale factor at T-point 221 zwi(ji,jj,1) = 0.e0 222 zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 223 END DO 224 END DO 225 ! 226 END IF 227 228 ! II.1. Vertical diffusion on tracer 229 ! --------------------------- 230 231 !! Matrix inversion from the first level 232 !!---------------------------------------------------------------------- 233 ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) 234 ! 235 ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) 236 ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) 237 ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) 238 ! ( ... )( ... ) ( ... ) 239 ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) 240 ! 241 ! m is decomposed in the product of an upper and lower triangular matrix 242 ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi 243 ! The second member is in 2d array zwy 244 ! The solution is in 2d array zwx 245 ! The 3d arry zwt is a work space array 246 ! zwy is used and then used as a work space array : its value is modified! 247 248 ! first recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) 220 249 DO jj = 2, jpjm1 221 250 DO ji = fs_2, fs_jpim1 222 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 223 END DO 224 END DO 225 END DO 226 227 ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 228 DO jj = 2, jpjm1 229 DO ji = fs_2, fs_jpim1 230 ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,1) 231 ze3tn = ( 1. - znvvl ) + znvvl * fse3t(ji,jj,1) 232 ta(ji,jj,1) = ze3tb * tb(ji,jj,1) + p2dt(1) * ze3tn * ta(ji,jj,1) 233 END DO 234 END DO 235 DO jk = 2, jpkm1 251 zwt(ji,jj,1) = zwd(ji,jj,1) 252 END DO 253 END DO 254 DO jk = 2, jpkm1 255 DO jj = 2, jpjm1 256 DO ji = fs_2, fs_jpim1 257 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 258 END DO 259 END DO 260 END DO 261 262 ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 236 263 DO jj = 2, jpjm1 237 264 DO ji = fs_2, fs_jpim1 238 ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,jk) 239 ze3tn = ( 1. - znvvl ) + znvvl * fse3t (ji,jj,jk) 240 zrhs = ze3tb * tb(ji,jj,jk) + p2dt(jk) * ze3tn * ta(ji,jj,jk) ! zrhs=right hand side 241 ta(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * ta(ji,jj,jk-1) 242 END DO 243 END DO 244 END DO 245 246 ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 247 ! Save the masked temperature after in ta 248 ! (c a u t i o n: temperature not its trend, Leap-frog scheme done it will not be done in tranxt) 249 DO jj = 2, jpjm1 250 DO ji = fs_2, fs_jpim1 251 ta(ji,jj,jpkm1) = ta(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 252 END DO 253 END DO 254 DO jk = jpk-2, 1, -1 265 ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,1) 266 ze3tn = ( 1. - znvvl ) + znvvl * fse3t(ji,jj,1) 267 ptraa(ji,jj,1,jn) = ze3tb * ptrab(ji,jj,1,jn) + p2dt(1) * ze3tn * ptraa(ji,jj,1,jn) 268 END DO 269 END DO 270 DO jk = 2, jpkm1 271 DO jj = 2, jpjm1 272 DO ji = fs_2, fs_jpim1 273 ze3tb = ( 1. - znvvl ) + znvvl * fse3t_b(ji,jj,jk) 274 ze3tn = ( 1. - znvvl ) + znvvl * fse3t (ji,jj,jk) 275 zrhs = ze3tb * ptrab(ji,jj,jk,jn) + p2dt(jk) * ze3tn * ptraa(ji,jj,jk,jn) ! zrhs=right hand side 276 ptraa(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * ptraa(ji,jj,jk-1,jn) 277 END DO 278 END DO 279 END DO 280 281 ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 282 ! Save the masked temperature after in ta 283 ! (c a u t i o n: temperature not its trend, Leap-frog scheme done it will not be done in tranxt) 255 284 DO jj = 2, jpjm1 256 285 DO ji = fs_2, fs_jpim1 257 ta(ji,jj,jk) = ( ta(ji,jj,jk) - zws(ji,jj,jk) * ta(ji,jj,jk+1) ) / zwt(ji,jj,jk) * tmask(ji,jj,jk) 258 END DO 259 END DO 260 END DO 261 262 ! II.2 Vertical diffusion on salinity 263 ! ----------------------------------- 264 265 #if defined key_zdfddm 266 ! Rebuild the Matrix as avt /= avs 267 268 ! Diagonal, inferior, superior (including the bottom boundary condition via avs masked) 269 DO jk = 1, jpkm1 270 DO jj = 2, jpjm1 271 DO ji = fs_2, fs_jpim1 ! vector opt. 272 ze3ta = ( 1. - znvvl ) & ! after scale factor at T-point 273 & + znvvl * fse3t_a(ji,jj,jk) 274 ze3tn = znvvl & ! now scale factor at T-point 275 & + ( 1. - znvvl ) * fse3t_n(ji,jj,jk) 276 zwi(ji,jj,jk) = - p2dt(jk) * zavsi(ji,jj,jk ) / ( ze3tn * fse3w(ji,jj,jk ) ) 277 zws(ji,jj,jk) = - p2dt(jk) * zavsi(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 278 zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 279 END DO 280 END DO 281 END DO 282 283 ! Surface boudary conditions 284 DO jj = 2, jpjm1 285 DO ji = fs_2, fs_jpim1 ! vector opt. 286 ze3ta = ( 1. - znvvl ) + znvvl * fse3t_a(ji,jj,1) 287 zwi(ji,jj,1) = 0.e0 288 zwd(ji,jj,1) = ze3ta - zws(ji,jj,1) 289 END DO 290 END DO 291 #endif 292 293 294 !! Matrix inversion from the first level 295 !!---------------------------------------------------------------------- 296 ! solve m.x = y where m is a tri diagonal matrix ( jpk*jpk ) 297 ! 298 ! ( zwd1 zws1 0 0 0 )( zwx1 ) ( zwy1 ) 299 ! ( zwi2 zwd2 zws2 0 0 )( zwx2 ) ( zwy2 ) 300 ! ( 0 zwi3 zwd3 zws3 0 )( zwx3 )=( zwy3 ) 301 ! ( ... )( ... ) ( ... ) 302 ! ( 0 0 0 zwik zwdk )( zwxk ) ( zwyk ) 303 ! 304 ! m is decomposed in the product of an upper and lower triangular 305 ! matrix 306 ! The 3 diagonal terms are in 2d arrays: zwd, zws, zwi 307 ! The second member is in 2d array zwy 308 ! The solution is in 2d array zwx 309 ! The 3d arry zwt is a work space array 310 ! zwy is used and then used as a work space array : its value is modified! 311 312 ! first recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) 313 DO jj = 2, jpjm1 314 DO ji = fs_2, fs_jpim1 315 zwt(ji,jj,1) = zwd(ji,jj,1) 316 END DO 317 END DO 318 DO jk = 2, jpkm1 319 DO jj = 2, jpjm1 320 DO ji = fs_2, fs_jpim1 321 zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 322 END DO 323 END DO 324 END DO 325 326 ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 327 DO jj = 2, jpjm1 328 DO ji = fs_2, fs_jpim1 329 ze3tb = ( 1. - znvvl ) & ! before scale factor at T-point 330 & + znvvl * fse3t_b(ji,jj,1) 331 ze3tn = ( 1. - znvvl ) + znvvl * fse3t (ji,jj,1) ! now scale factor at T-point 332 sa(ji,jj,1) = ze3tb * sb(ji,jj,1) + p2dt(1) * ze3tn * sa(ji,jj,1) 333 END DO 334 END DO 335 DO jk = 2, jpkm1 336 DO jj = 2, jpjm1 337 DO ji = fs_2, fs_jpim1 338 ze3tb = ( 1. - znvvl ) & ! before scale factor at T-point 339 & + znvvl * fse3t_b(ji,jj,jk) 340 ze3tn = ( 1. - znvvl ) + znvvl * fse3t (ji,jj,jk) ! now scale factor at T-point 341 zrhs = ze3tb * sb(ji,jj,jk) + p2dt(jk) * ze3tn * sa(ji,jj,jk) ! zrhs=right hand side 342 sa(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *sa(ji,jj,jk-1) 343 END DO 344 END DO 345 END DO 346 347 ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 348 ! Save the masked temperature after in ta 349 ! (c a u t i o n: temperature not its trend, Leap-frog scheme done it will not be done in tranxt) 350 DO jj = 2, jpjm1 351 DO ji = fs_2, fs_jpim1 352 sa(ji,jj,jpkm1) = sa(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 353 END DO 354 END DO 355 DO jk = jpk-2, 1, -1 356 DO jj = 2, jpjm1 357 DO ji = fs_2, fs_jpim1 358 sa(ji,jj,jk) = ( sa(ji,jj,jk) - zws(ji,jj,jk) * sa(ji,jj,jk+1) ) / zwt(ji,jj,jk) * tmask(ji,jj,jk) 359 END DO 360 END DO 286 ptraa(ji,jj,jpkm1,jn) = ptraa(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 287 END DO 288 END DO 289 DO jk = jpk-2, 1, -1 290 DO jj = 2, jpjm1 291 DO ji = fs_2, fs_jpim1 292 ptraa(ji,jj,jk,jn) = ( ptraa(ji,jj,jk,jn) - zws(ji,jj,jk) * ptraa(ji,jj,jk+1,jn) ) & 293 & / zwt(ji,jj,jk) * tmask(ji,jj,jk) 294 END DO 295 END DO 296 END DO 297 ! 361 298 END DO 362 299 ! -
branches/DEV_r2006_merge_TRA_TRC/NEMO/OPA_SRC/TRA/zpshde.F90
r1152 r2024 4 4 !! z-coordinate - partial step : Horizontal Derivative 5 5 !!============================================================================== 6 !! History : 7 !! OPA 8.5 ! 2002-04 (A. Bozec) Original code 8 !! 8.5 ! 2002-08 (G. Madec E. Durand) Optimization and Free form 9 !! 9.0 ! 2004-03 (C. Ethe) adapted for passive tracers 10 !! NEMO 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 11 !!============================================================================== 6 12 7 13 !!---------------------------------------------------------------------- 8 14 !! zps_hde : Horizontal DErivative of T, S and rd at the last 15 !! ocean level (Z-coord. with Partial Steps) 16 !! zps_hde_trc : Horizontal DErivative of passive tracers at the last 9 17 !! ocean level (Z-coord. with Partial Steps) 10 18 !!---------------------------------------------------------------------- … … 22 30 !! * Routine accessibility 23 31 PUBLIC zps_hde ! routine called by step.F90 32 PUBLIC zps_hde_init ! routine called by opa.F90 33 #if defined key_top 34 PUBLIC zps_hde_trc 35 #endif 24 36 25 37 !! * module variables … … 37 49 !!---------------------------------------------------------------------- 38 50 CONTAINS 39 40 51 SUBROUTINE zps_hde ( kt, ptem, psal, prd , & 41 52 pgtu, pgsu, pgru, & … … 84 95 !! - pgtv, pgsv, pgrv: horizontal gradient of T, S 85 96 !! and rd at V-points 86 !!87 !! History :88 !! 8.5 ! 02-04 (A. Bozec) Original code89 !! 8.5 ! 02-08 (G. Madec E. Durand) Optimization and Free form90 97 !!---------------------------------------------------------------------- 91 98 !! * Arguments 92 99 INTEGER, INTENT( in ) :: kt ! ocean time-step index 93 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: & 94 ptem, psal, prd ! 3D T, S and rd fields 95 REAL(wp), DIMENSION(jpi,jpj), INTENT( out ) :: & 96 pgtu, pgsu, pgru, & ! horizontal grad. of T, S and rd at u- 97 pgtv, pgsv, pgrv ! and v-points of the partial step level 98 100 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: ptem, psal, prd ! 3D T, S and rd fields 101 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out ) :: pgtu, pgsu, pgru ! horizontal grad. of T, S and rd at u-point 102 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out ) :: pgtv, pgsv, pgrv ! horizontal grad. of T, S and rd at v-point 99 103 !! * Local declarations 100 INTEGER :: ji, jj, & ! Dummy loop indices 101 iku,ikv ! partial step level at u- and v-points 102 REAL(wp), DIMENSION(jpi,jpj) :: & 103 zti, ztj, zsi, zsj, & ! interpolated value of T, S 104 zri, zrj, & ! and rd 105 zhgi, zhgj ! depth of interpolation for eos2d 106 REAL(wp) :: & 107 ze3wu, ze3wv, & ! temporary scalars 108 zmaxu1, zmaxu2, & ! " " 109 zmaxv1, zmaxv2 ! " " 110 111 ! Initialization (first time-step only): compute mbatu and mbatv 112 IF( kt == nit000 ) THEN 113 mbatu(:,:) = 0 114 mbatv(:,:) = 0 115 DO jj = 1, jpjm1 116 DO ji = 1, fs_jpim1 ! vector opt. 117 mbatu(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1, 2 ) 118 mbatv(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1, 2 ) 119 END DO 120 END DO 121 zti(:,:) = FLOAT( mbatu(:,:) ) 122 ztj(:,:) = FLOAT( mbatv(:,:) ) 123 ! lateral boundary conditions: T-point, sign unchanged 124 CALL lbc_lnk( zti , 'U', 1. ) 125 CALL lbc_lnk( ztj , 'V', 1. ) 126 mbatu(:,:) = MAX( INT( zti(:,:) ), 2 ) 127 mbatv(:,:) = MAX( INT( ztj(:,:) ), 2 ) 128 ENDIF 129 104 INTEGER :: ji , jj ! Dummy loop indices 105 INTEGER :: iku, ikv ! partial step level at u- and v-points 106 REAL(wp), DIMENSION(jpi,jpj) :: zti, ztj, zsi, zsj ! interpolated value of T, S 107 REAL(wp), DIMENSION(jpi,jpj) :: zri, zrj ! interpolated value of rd 108 REAL(wp), DIMENSION(jpi,jpj) :: zhgi, zhgj ! depth of interpolation for eos2d 109 REAL(wp) :: ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars 110 130 111 131 112 ! Interpolation of T and S at the last ocean level … … 140 121 iku = mbatu(ji,jj) 141 122 ikv = mbatv(ji,jj) 142 143 123 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 144 124 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 145 zmaxu1 = ze3wu / fse3w(ji+1,jj ,iku)146 zmaxu2 = -ze3wu / fse3w(ji ,jj ,iku)147 zmaxv1 = ze3wv / fse3w(ji ,jj+1,ikv)148 zmaxv2 = -ze3wv / fse3w(ji ,jj ,ikv)149 125 150 126 ! i- direction 151 152 127 IF( ze3wu >= 0. ) THEN ! case 1 153 128 ! interpolated values of T and S 154 zti(ji,jj) = ptem(ji+1,jj,iku) + zmaxu1 * ( ptem(ji+1,jj,iku-1) - ptem(ji+1,jj,iku) ) 155 zsi(ji,jj) = psal(ji+1,jj,iku) + zmaxu1 * ( psal(ji+1,jj,iku-1) - psal(ji+1,jj,iku) ) 129 zmaxu = ze3wu / fse3w(ji+1,jj,iku) 130 zti(ji,jj) = ptem(ji+1,jj,iku) + zmaxu * ( ptem(ji+1,jj,iku-1) - ptem(ji+1,jj,iku) ) 131 zsi(ji,jj) = psal(ji+1,jj,iku) + zmaxu * ( psal(ji+1,jj,iku-1) - psal(ji+1,jj,iku) ) 156 132 ! depth of the partial step level 157 133 zhgi(ji,jj) = fsdept(ji,jj,iku) … … 162 138 ELSE ! case 2 163 139 ! interpolated values of T and S 164 zti(ji,jj) = ptem(ji,jj,iku) + zmaxu2 * ( ptem(ji,jj,iku-1) - ptem(ji,jj,iku) ) 165 zsi(ji,jj) = psal(ji,jj,iku) + zmaxu2 * ( psal(ji,jj,iku-1) - psal(ji,jj,iku) ) 140 zmaxu = -ze3wu / fse3w(ji,jj,iku) 141 zti(ji,jj) = ptem(ji,jj,iku) + zmaxu * ( ptem(ji,jj,iku-1) - ptem(ji,jj,iku) ) 142 zsi(ji,jj) = psal(ji,jj,iku) + zmaxu * ( psal(ji,jj,iku-1) - psal(ji,jj,iku) ) 166 143 ! depth of the partial step level 167 144 zhgi(ji,jj) = fsdept(ji+1,jj,iku) … … 172 149 173 150 ! j- direction 174 175 151 IF( ze3wv >= 0. ) THEN ! case 1 176 152 ! interpolated values of T and S 177 ztj(ji,jj) = ptem(ji,jj+1,ikv) + zmaxv1 * ( ptem(ji,jj+1,ikv-1) - ptem(ji,jj+1,ikv) ) 178 zsj(ji,jj) = psal(ji,jj+1,ikv) + zmaxv1 * ( psal(ji,jj+1,ikv-1) - psal(ji,jj+1,ikv) ) 153 zmaxv = ze3wv / fse3w(ji,jj+1,ikv) 154 ztj(ji,jj) = ptem(ji,jj+1,ikv) + zmaxv * ( ptem(ji,jj+1,ikv-1) - ptem(ji,jj+1,ikv) ) 155 zsj(ji,jj) = psal(ji,jj+1,ikv) + zmaxv * ( psal(ji,jj+1,ikv-1) - psal(ji,jj+1,ikv) ) 179 156 ! depth of the partial step level 180 157 zhgj(ji,jj) = fsdept(ji,jj,ikv) … … 185 162 ELSE ! case 2 186 163 ! interpolated values of T and S 187 ztj(ji,jj) = ptem(ji,jj,ikv) + zmaxv2 * ( ptem(ji,jj,ikv-1) - ptem(ji,jj,ikv) ) 188 zsj(ji,jj) = psal(ji,jj,ikv) + zmaxv2 * ( psal(ji,jj,ikv-1) - psal(ji,jj,ikv) ) 164 zmaxv = -ze3wv / fse3w(ji,jj,ikv) 165 ztj(ji,jj) = ptem(ji,jj,ikv) + zmaxv * ( ptem(ji,jj,ikv-1) - ptem(ji,jj,ikv) ) 166 zsj(ji,jj) = psal(ji,jj,ikv) + zmaxv * ( psal(ji,jj,ikv-1) - psal(ji,jj,ikv) ) 189 167 ! depth of the partial step level 190 168 zhgj(ji,jj) = fsdept(ji,jj+1,ikv) … … 238 216 END SUBROUTINE zps_hde 239 217 218 #if defined key_top 219 !!---------------------------------------------------------------------- 220 !! 'key_top' TOP models 221 !!---------------------------------------------------------------------- 222 SUBROUTINE zps_hde_trc ( kt, kjpt, ptra, pgtru, pgtrv ) 223 !!---------------------------------------------------------------------- 224 !! *** ROUTINE zps_hde_trc *** 225 !! 226 !! ** Purpose : Compute the horizontal derivative of passive tracers 227 !! TRA at u- and v-points with a linear interpolation for z-coordinate 228 !! with partial steps. 229 !! 230 !! ** Method : the same for T & S 231 !! 232 !! ** Action : - pgtru : horizontal gradient of TRA at U-points 233 !! - pgtrv : horizontal gradient of TRA at V-points 234 !!---------------------------------------------------------------------- 235 !! * Arguments 236 INTEGER , INTENT( in ) :: kt ! ocean time-step index 237 INTEGER , INTENT( in ) :: kjpt ! number of tracers 238 REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT( in ) :: ptra ! 4D tracers fields 239 REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out ) :: pgtru, pgtrv ! horizontal grad. of TRA u- and v-points 240 !! * Local declarations 241 INTEGER :: ji, jj, jn ! Dummy loop indices 242 INTEGER :: iku, ikv ! partial step level at u- and v-points 243 REAL(wp) :: ztrai, ztraj, ze3wu, ze3wv, zmaxu, zmaxv ! temporary scalars 244 !!---------------------------------------------------------------------- 245 246 DO jn = 1, kjpt 247 ! Interpolation of passive tracers at the last ocean level 248 # if defined key_vectopt_loop 249 jj = 1 250 DO ji = 1, jpij-jpi ! vector opt. (forced unrolled) 251 # else 252 DO jj = 1, jpjm1 253 DO ji = 1, jpim1 254 # endif 255 ! last level 256 iku = mbatu(ji,jj) 257 ikv = mbatv(ji,jj) 258 ze3wu = fse3w(ji+1,jj ,iku) - fse3w(ji,jj,iku) 259 ze3wv = fse3w(ji ,jj+1,ikv) - fse3w(ji,jj,ikv) 260 261 ! i- direction 262 IF( ze3wu >= 0. ) THEN ! case 1 263 zmaxu = ze3wu / fse3w(ji+1,jj,iku) 264 ! interpolated values of passive tracers 265 ztrai = ptra(ji+1,jj,iku,jn) + zmaxu * ( ptra(ji+1,jj,iku-1,jn) - ptra(ji+1,jj,iku,jn) ) 266 ! gradient of passive tracers 267 pgtru(ji,jj,jn) = umask(ji,jj,1) * ( ztrai - ptra(ji,jj,iku,jn) ) 268 ELSE ! case 2 269 zmaxu = -ze3wu / fse3w(ji,jj,iku) 270 ! interpolated values of passive tracers 271 ztrai = ptra(ji,jj,iku,jn) + zmaxu * ( ptra(ji,jj,iku-1,jn) - ptra(ji,jj,iku,jn) ) 272 ! gradient of passive tracers 273 pgtru(ji,jj,jn) = umask(ji,jj,1) * ( ptra(ji+1,jj,iku,jn) - ztrai ) 274 ENDIF 275 276 ! j- direction 277 IF( ze3wv >= 0. ) THEN ! case 1 278 zmaxv = ze3wv / fse3w(ji,jj+1,ikv) 279 ! interpolated values of passive tracers 280 ztraj = ptra(ji,jj+1,ikv,jn) + zmaxv * ( ptra(ji,jj+1,ikv-1,jn) - ptra(ji,jj+1,ikv,jn) ) 281 ! gradient of passive tracers 282 pgtrv(ji,jj,jn) = vmask(ji,jj,1) * ( ztraj - ptra(ji,jj,ikv,jn) ) 283 ELSE ! case 2 284 zmaxv = -ze3wv / fse3w(ji,jj,ikv) 285 ! interpolated values of passive tracers 286 ztraj = ptra(ji,jj,ikv,jn) + zmaxv * ( ptra(ji,jj,ikv-1,jn) - ptra(ji,jj,ikv,jn) ) 287 ! gradient of passive tracers 288 pgtrv(ji,jj,jn) = vmask(ji,jj,1) * ( ptra(ji,jj+1,ikv,jn) - ztraj ) 289 ENDIF 290 # if ! defined key_vectopt_loop 291 END DO 292 # endif 293 END DO 294 295 ! Lateral boundary conditions on each gradient 296 CALL lbc_lnk( pgtru(:,:,jn) , 'U', -1. ) 297 CALL lbc_lnk( pgtrv(:,:,jn) , 'V', -1. ) 298 299 END DO 300 301 END SUBROUTINE zps_hde_trc 302 #endif 303 304 SUBROUTINE zps_hde_init 305 !!---------------------------------------------------------------------- 306 !! *** ROUTINE zps_hde_init *** 307 !! 308 !! ** Purpose : Computation of bottom ocean level index at U- and V-points 309 !! 310 !!---------------------------------------------------------------------- 311 !! * Local declarations 312 INTEGER :: ji, jj ! Dummy loop indices 313 REAL(wp), DIMENSION(jpi,jpj) :: zti, ztj ! temporary arrays 314 !!---------------------------------------------------------------------- 315 316 mbatu(:,:) = 0 317 mbatv(:,:) = 0 318 DO jj = 1, jpjm1 319 DO ji = 1, fs_jpim1 ! vector opt. 320 mbatu(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji+1,jj ) ) - 1, 2 ) 321 mbatv(ji,jj) = MAX( MIN( mbathy(ji,jj), mbathy(ji ,jj+1) ) - 1, 2 ) 322 END DO 323 END DO 324 zti(:,:) = FLOAT( mbatu(:,:) ) 325 ztj(:,:) = FLOAT( mbatv(:,:) ) 326 ! lateral boundary conditions: T-point, sign unchanged 327 CALL lbc_lnk( zti , 'U', 1. ) 328 CALL lbc_lnk( ztj , 'V', 1. ) 329 mbatu(:,:) = MAX( INT( zti(:,:) ), 2 ) 330 mbatv(:,:) = MAX( INT( ztj(:,:) ), 2 ) 331 332 END SUBROUTINE zps_hde_init 240 333 !!====================================================================== 241 334 END MODULE zpshde
Note: See TracChangeset
for help on using the changeset viewer.