- Timestamp:
- 2020-05-14T21:46:00+02:00 (4 years ago)
- Location:
- NEMO/branches/2019/dev_r11078_OSMOSIS_IMMERSE_Nurser
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/DIA/diaptr.F90 (modified) (16 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r11078_OSMOSIS_IMMERSE_Nurser
- Property svn:externals
-
old new 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 9 # SETTE 10 ^/utils/CI/sette@HEAD sette
-
- Property svn:externals
-
NEMO/branches/2019/dev_r11078_OSMOSIS_IMMERSE_Nurser/src/OCE/DIA/diaptr.F90
r12178 r12928 10 10 !! 3.6 ! 2014-12 (C. Ethe) use of IOM 11 11 !! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6 12 !! 4.0 ! 2010-08 ( C. Ethe, J. Deshayes ) Improvment 12 13 !!---------------------------------------------------------------------- 13 14 … … 42 43 43 44 ! !!** namelist namptr ** 44 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_adv, htr_ldf, htr_eiv !: Heat TRansports (adv, diff, Bolus.) 45 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: str_adv, str_ldf, str_eiv !: Salt TRansports (adv, diff, Bolus.) 46 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_ove, str_ove !: heat Salt TRansports ( overturn.) 47 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_btr, str_btr !: heat Salt TRansports ( barotropic ) 48 49 LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) 50 LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation 51 INTEGER, PUBLIC :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T) 45 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.) 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 47 48 LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini) 49 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 52 50 53 51 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup 54 REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x r au0 x Cp)55 REAL(wp) :: rc_ggram = 1.e- 6_wp ! conversion from g to Pg56 57 CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:) :: clsubb58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 60 61 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(: ) :: p_fval1d62 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 63 52 REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rho0 x Cp) 53 REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rho0) 54 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 57 58 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d 59 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 60 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini) 64 62 !! * Substitutions 65 # include " vectopt_loop_substitute.h90"63 # include "do_loop_substitute.h90" 66 64 !!---------------------------------------------------------------------- 67 65 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 71 69 CONTAINS 72 70 73 SUBROUTINE dia_ptr( pvtr )71 SUBROUTINE dia_ptr( kt, Kmm, pvtr ) 74 72 !!---------------------------------------------------------------------- 75 73 !! *** ROUTINE dia_ptr *** 76 74 !!---------------------------------------------------------------------- 75 INTEGER , INTENT(in) :: kt ! ocean time-step index 76 INTEGER , INTENT(in) :: Kmm ! time level index 77 77 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 78 78 ! … … 80 80 REAL(wp) :: zsfc,zvfc ! local scalar 81 81 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace83 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace 83 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace 84 84 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace 85 REAL(wp), DIMENSION(jpj) :: vsum ! 1D workspace 86 REAL(wp), DIMENSION(jpj,jpts) :: tssum ! 1D workspace 87 85 REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace 88 86 ! 89 87 !overturning calculation 90 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 91 REAL(wp), DIMENSION(jpj,jpk,nptr) :: v_msf, sn_jk , tn_jk ! i-mean T and S, j-Stream-Function 92 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvn ! 3D workspace 93 94 95 CHARACTER( len = 12 ) :: cl1 88 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse 89 REAL(wp), DIMENSION(jpj,jpk,nptr) :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function 90 91 REAL(wp), DIMENSION(jpi,jpj,jpk,nptr) :: z4d1, z4d2 92 REAL(wp), DIMENSION(jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function 96 93 !!---------------------------------------------------------------------- 97 94 ! 98 95 IF( ln_timing ) CALL timing_start('dia_ptr') 99 96 100 ! 97 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init 98 ! 99 IF( .NOT. l_diaptr ) RETURN 100 101 101 IF( PRESENT( pvtr ) ) THEN 102 IF( iom_use("zomsfglo") ) THEN ! effective MSF 103 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) ) ! zonal cumulative effective transport 104 DO jk = 2, jpkm1 105 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 102 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF 103 DO jn = 1, nptr ! by sub-basins 104 z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) ! zonal cumulative effective transport excluding closed seas 105 DO jk = jpkm1, 1, -1 106 z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF) 107 END DO 108 DO ji = 1, jpi 109 z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 110 ENDDO 106 111 END DO 107 DO ji = 1, jpi 108 z3d(ji,:,:) = z3d(1,:,:) 109 ENDDO 110 cl1 = TRIM('zomsf'//clsubb(1) ) 111 CALL iom_put( cl1, z3d * rc_sv ) 112 DO jn = 2, nptr ! by sub-basins 113 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 114 DO jk = 2, jpkm1 115 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 116 END DO 117 DO ji = 1, jpi 118 z3d(ji,:,:) = z3d(1,:,:) 119 ENDDO 120 cl1 = TRIM('zomsf'//clsubb(jn) ) 121 CALL iom_put( cl1, z3d * rc_sv ) 122 END DO 123 ENDIF 124 IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 112 CALL iom_put( 'zomsf', z4d1 * rc_sv ) 113 ENDIF 114 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 115 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 125 116 ! define fields multiplied by scalar 126 117 zmask(:,:,:) = 0._wp 127 118 zts(:,:,:,:) = 0._wp 128 zvn(:,:,:) = 0._wp 129 DO jk = 1, jpkm1 130 DO jj = 1, jpjm1 131 DO ji = 1, jpi 132 zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk) 133 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 134 zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc !Tracers averaged onto V grid 135 zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 136 zvn(ji,jj,jk) = vn(ji,jj,jk) * zvfc 137 ENDDO 138 ENDDO 139 ENDDO 140 ENDIF 141 IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN 142 sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) ) 143 r1_sjk(:,:,1) = 0._wp 144 WHERE( sjk(:,:,1) /= 0._wp ) r1_sjk(:,:,1) = 1._wp / sjk(:,:,1) 145 146 ! i-mean T and S, j-Stream-Function, global 147 tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1) 148 sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1) 149 v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) ) 150 151 htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 ) 152 str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 ) 153 154 z2d(1,:) = htr_ove(:,1) * rc_pwatt ! (conversion in PW) 155 DO ji = 1, jpi 156 z2d(ji,:) = z2d(1,:) 157 ENDDO 158 cl1 = 'sophtove' 159 CALL iom_put( TRIM(cl1), z2d ) 160 z2d(1,:) = str_ove(:,1) * rc_ggram ! (conversion in Gg) 161 DO ji = 1, jpi 162 z2d(ji,:) = z2d(1,:) 163 ENDDO 164 cl1 = 'sopstove' 165 CALL iom_put( TRIM(cl1), z2d ) 166 IF( ln_subbas ) THEN 167 DO jn = 2, nptr 168 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 169 r1_sjk(:,:,jn) = 0._wp 170 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 171 172 ! i-mean T and S, j-Stream-Function, basin 173 tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 174 sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 175 v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) ) 176 htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 ) 177 str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 ) 178 179 z2d(1,:) = htr_ove(:,jn) * rc_pwatt ! (conversion in PW) 180 DO ji = 1, jpi 181 z2d(ji,:) = z2d(1,:) 182 ENDDO 183 cl1 = TRIM('sophtove_'//clsubb(jn)) 184 CALL iom_put( cl1, z2d ) 185 z2d(1,:) = str_ove(:,jn) * rc_ggram ! (conversion in Gg) 186 DO ji = 1, jpi 187 z2d(ji,:) = z2d(1,:) 188 ENDDO 189 cl1 = TRIM('sopstove_'//clsubb(jn)) 190 CALL iom_put( cl1, z2d ) 191 END DO 192 ENDIF 193 ENDIF 194 IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 195 ! Calculate barotropic heat and salt transport here 196 sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) ) 197 r1_sjk(:,1,1) = 0._wp 198 WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1) 199 200 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1)) 201 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) ) 202 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) ) 203 htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1) 204 str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1) 205 z2d(1,:) = htr_btr(:,1) * rc_pwatt ! (conversion in PW) 206 DO ji = 2, jpi 207 z2d(ji,:) = z2d(1,:) 208 ENDDO 209 cl1 = 'sophtbtr' 210 CALL iom_put( TRIM(cl1), z2d ) 211 z2d(1,:) = str_btr(:,1) * rc_ggram ! (conversion in Gg) 212 DO ji = 2, jpi 213 z2d(ji,:) = z2d(1,:) 214 ENDDO 215 cl1 = 'sopstbtr' 216 CALL iom_put( TRIM(cl1), z2d ) 217 IF( ln_subbas ) THEN 218 DO jn = 2, nptr 219 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 220 r1_sjk(:,1,jn) = 0._wp 221 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 222 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn)) 223 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 224 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 225 htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn) 226 str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn) 227 z2d(1,:) = htr_btr(:,jn) * rc_pwatt ! (conversion in PW) 228 DO ji = 1, jpi 229 z2d(ji,:) = z2d(1,:) 230 ENDDO 231 cl1 = TRIM('sophtbtr_'//clsubb(jn)) 232 CALL iom_put( cl1, z2d ) 233 z2d(1,:) = str_btr(:,jn) * rc_ggram ! (conversion in Gg) 234 DO ji = 1, jpi 235 z2d(ji,:) = z2d(1,:) 236 ENDDO 237 cl1 = TRIM('sopstbtr_'//clsubb(jn)) 238 CALL iom_put( cl1, z2d ) 239 ENDDO 240 ENDIF !ln_subbas 241 ENDIF !iom_use("sopstbtr....) 119 DO_3D_10_11( 1, jpkm1 ) 120 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 121 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 122 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid 123 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 124 END_3D 125 ENDIF 126 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 127 DO jn = 1, nptr 128 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 129 r1_sjk(:,:,jn) = 0._wp 130 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 131 ! i-mean T and S, j-Stream-Function, basin 132 zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 133 zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 134 v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 135 hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 136 hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 137 ! 138 ENDDO 139 DO jn = 1, nptr 140 z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 141 DO ji = 1, jpi 142 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 143 ENDDO 144 ENDDO 145 CALL iom_put( 'sophtove', z3dtr ) 146 DO jn = 1, nptr 147 z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 148 DO ji = 1, jpi 149 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 150 ENDDO 151 ENDDO 152 CALL iom_put( 'sopstove', z3dtr ) 153 ENDIF 154 155 IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 156 ! Calculate barotropic heat and salt transport here 157 DO jn = 1, nptr 158 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 159 r1_sjk(:,1,jn) = 0._wp 160 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 161 ! 162 zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) ) 163 ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 164 zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 165 hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 166 hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 167 ! 168 ENDDO 169 DO jn = 1, nptr 170 z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 171 DO ji = 1, jpi 172 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 173 ENDDO 174 ENDDO 175 CALL iom_put( 'sophtbtr', z3dtr ) 176 DO jn = 1, nptr 177 z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 178 DO ji = 1, jpi 179 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 180 ENDDO 181 ENDDO 182 CALL iom_put( 'sopstbtr', z3dtr ) 183 ENDIF 242 184 ! 243 185 ELSE 244 186 ! 245 IF( iom_use("zotemglo") ) THEN ! i-mean i-k-surface 246 DO jk = 1, jpkm1 247 DO jj = 1, jpj 248 DO ji = 1, jpi 249 zsfc = e1t(ji,jj) * e3t_n(ji,jj,jk) 250 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 251 zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc 252 zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc 253 END DO 254 END DO 255 END DO 187 zmask(:,:,:) = 0._wp 188 zts(:,:,:,:) = 0._wp 189 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 190 DO_3D_11_11( 1, jpkm1 ) 191 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 192 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 193 zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc 194 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 195 END_3D 196 ! 256 197 DO jn = 1, nptr 257 198 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 258 cl1 = TRIM('zosrf'//clsubb(jn) ) 259 CALL iom_put( cl1, zmask ) 260 ! 261 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 262 & / MAX( zmask(1,:,:), 10.e-15 ) 263 DO ji = 1, jpi 264 z3d(ji,:,:) = z3d(1,:,:) 265 ENDDO 266 cl1 = TRIM('zotem'//clsubb(jn) ) 267 CALL iom_put( cl1, z3d ) 268 ! 269 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 270 & / MAX( zmask(1,:,:), 10.e-15 ) 271 DO ji = 1, jpi 272 z3d(ji,:,:) = z3d(1,:,:) 273 ENDDO 274 cl1 = TRIM('zosal'//clsubb(jn) ) 275 CALL iom_put( cl1, z3d ) 276 END DO 199 z4d1(:,:,:,jn) = zmask(:,:,:) 200 ENDDO 201 CALL iom_put( 'zosrf', z4d1 ) 202 ! 203 DO jn = 1, nptr 204 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 205 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 206 DO ji = 1, jpi 207 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 208 ENDDO 209 ENDDO 210 CALL iom_put( 'zotem', z4d2 ) 211 ! 212 DO jn = 1, nptr 213 z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 214 & / MAX( z4d1(1,:,:,jn), 10.e-15 ) 215 DO ji = 1, jpi 216 z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 217 ENDDO 218 ENDDO 219 CALL iom_put( 'zosal', z4d2 ) 220 ! 277 221 ENDIF 278 222 ! 279 223 ! ! Advective and diffusive heat and salt transport 280 IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN 281 z2d(1,:) = htr_adv(:,1) * rc_pwatt ! (conversion in PW) 282 DO ji = 1, jpi 283 z2d(ji,:) = z2d(1,:) 284 ENDDO 285 cl1 = 'sophtadv' 286 CALL iom_put( TRIM(cl1), z2d ) 287 z2d(1,:) = str_adv(:,1) * rc_ggram ! (conversion in Gg) 288 DO ji = 1, jpi 289 z2d(ji,:) = z2d(1,:) 290 ENDDO 291 cl1 = 'sopstadv' 292 CALL iom_put( TRIM(cl1), z2d ) 293 IF( ln_subbas ) THEN 294 DO jn=2,nptr 295 z2d(1,:) = htr_adv(:,jn) * rc_pwatt ! (conversion in PW) 296 DO ji = 1, jpi 297 z2d(ji,:) = z2d(1,:) 298 ENDDO 299 cl1 = TRIM('sophtadv_'//clsubb(jn)) 300 CALL iom_put( cl1, z2d ) 301 z2d(1,:) = str_adv(:,jn) * rc_ggram ! (conversion in Gg) 302 DO ji = 1, jpi 303 z2d(ji,:) = z2d(1,:) 304 ENDDO 305 cl1 = TRIM('sopstadv_'//clsubb(jn)) 306 CALL iom_put( cl1, z2d ) 307 ENDDO 308 ENDIF 309 ENDIF 310 ! 311 IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN 312 z2d(1,:) = htr_ldf(:,1) * rc_pwatt ! (conversion in PW) 313 DO ji = 1, jpi 314 z2d(ji,:) = z2d(1,:) 315 ENDDO 316 cl1 = 'sophtldf' 317 CALL iom_put( TRIM(cl1), z2d ) 318 z2d(1,:) = str_ldf(:,1) * rc_ggram ! (conversion in Gg) 319 DO ji = 1, jpi 320 z2d(ji,:) = z2d(1,:) 321 ENDDO 322 cl1 = 'sopstldf' 323 CALL iom_put( TRIM(cl1), z2d ) 324 IF( ln_subbas ) THEN 325 DO jn=2,nptr 326 z2d(1,:) = htr_ldf(:,jn) * rc_pwatt ! (conversion in PW) 327 DO ji = 1, jpi 328 z2d(ji,:) = z2d(1,:) 329 ENDDO 330 cl1 = TRIM('sophtldf_'//clsubb(jn)) 331 CALL iom_put( cl1, z2d ) 332 z2d(1,:) = str_ldf(:,jn) * rc_ggram ! (conversion in Gg) 333 DO ji = 1, jpi 334 z2d(ji,:) = z2d(1,:) 335 ENDDO 336 cl1 = TRIM('sopstldf_'//clsubb(jn)) 337 CALL iom_put( cl1, z2d ) 338 ENDDO 339 ENDIF 340 ENDIF 341 342 IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN 343 z2d(1,:) = htr_eiv(:,1) * rc_pwatt ! (conversion in PW) 344 DO ji = 1, jpi 345 z2d(ji,:) = z2d(1,:) 346 ENDDO 347 cl1 = 'sophteiv' 348 CALL iom_put( TRIM(cl1), z2d ) 349 z2d(1,:) = str_eiv(:,1) * rc_ggram ! (conversion in Gg) 350 DO ji = 1, jpi 351 z2d(ji,:) = z2d(1,:) 352 ENDDO 353 cl1 = 'sopsteiv' 354 CALL iom_put( TRIM(cl1), z2d ) 355 IF( ln_subbas ) THEN 356 DO jn=2,nptr 357 z2d(1,:) = htr_eiv(:,jn) * rc_pwatt ! (conversion in PW) 358 DO ji = 1, jpi 359 z2d(ji,:) = z2d(1,:) 360 ENDDO 361 cl1 = TRIM('sophteiv_'//clsubb(jn)) 362 CALL iom_put( cl1, z2d ) 363 z2d(1,:) = str_eiv(:,jn) * rc_ggram ! (conversion in Gg) 364 DO ji = 1, jpi 365 z2d(ji,:) = z2d(1,:) 366 ENDDO 367 cl1 = TRIM('sopsteiv_'//clsubb(jn)) 368 CALL iom_put( cl1, z2d ) 369 ENDDO 370 ENDIF 224 IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN 225 ! 226 DO jn = 1, nptr 227 z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 228 DO ji = 1, jpi 229 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 230 ENDDO 231 ENDDO 232 CALL iom_put( 'sophtadv', z3dtr ) 233 DO jn = 1, nptr 234 z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 235 DO ji = 1, jpi 236 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 237 ENDDO 238 ENDDO 239 CALL iom_put( 'sopstadv', z3dtr ) 240 ENDIF 241 ! 242 IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN 243 ! 244 DO jn = 1, nptr 245 z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 246 DO ji = 1, jpi 247 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 248 ENDDO 249 ENDDO 250 CALL iom_put( 'sophtldf', z3dtr ) 251 DO jn = 1, nptr 252 z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 253 DO ji = 1, jpi 254 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 255 ENDDO 256 ENDDO 257 CALL iom_put( 'sopstldf', z3dtr ) 258 ENDIF 259 ! 260 IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN 261 ! 262 DO jn = 1, nptr 263 z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 264 DO ji = 1, jpi 265 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 266 ENDDO 267 ENDDO 268 CALL iom_put( 'sophteiv', z3dtr ) 269 DO jn = 1, nptr 270 z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 271 DO ji = 1, jpi 272 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 273 ENDDO 274 ENDDO 275 CALL iom_put( 'sopsteiv', z3dtr ) 276 ENDIF 277 ! 278 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 279 zts(:,:,:,:) = 0._wp 280 DO_3D_10_11( 1, jpkm1 ) 281 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 282 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid 283 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 284 END_3D 285 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 286 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 287 DO jn = 1, nptr 288 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) 289 DO ji = 1, jpi 290 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 291 ENDDO 292 ENDDO 293 CALL iom_put( 'sophtvtr', z3dtr ) 294 DO jn = 1, nptr 295 z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) 296 DO ji = 1, jpi 297 z3dtr(ji,:,jn) = z3dtr(1,:,jn) 298 ENDDO 299 ENDDO 300 CALL iom_put( 'sopstvtr', z3dtr ) 301 ENDIF 302 ! 303 IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 304 CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 305 z2d(:,:) = ptr_ci_2d( z2d(:,:) ) 306 CALL iom_put( 'uocetr_vsum_cumul', z2d ) 371 307 ENDIF 372 308 ! … … 384 320 !! ** Purpose : Initialization, namelist read 385 321 !!---------------------------------------------------------------------- 386 INTEGER :: jn ! local integers 387 INTEGER :: inum, ierr ! local integers 388 INTEGER :: ios ! Local integer output status for namelist read 389 !! 390 NAMELIST/namptr/ ln_diaptr, ln_subbas 391 !!---------------------------------------------------------------------- 392 393 REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport 394 READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901) 395 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' ) 396 397 REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport 398 READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) 399 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) 400 IF(lwm) WRITE ( numond, namptr ) 401 322 INTEGER :: inum, jn ! local integers 323 !! 324 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 325 !!---------------------------------------------------------------------- 326 327 l_diaptr = .FALSE. 328 IF( iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 329 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 330 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 331 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 332 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 333 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) ) l_diaptr = .TRUE. 334 335 402 336 IF(lwp) THEN ! Control print 403 337 WRITE(numout,*) … … 405 339 WRITE(numout,*) '~~~~~~~~~~~~' 406 340 WRITE(numout,*) ' Namelist namptr : set ptr parameters' 407 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr 408 WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas 341 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr 409 342 ENDIF 410 343 411 IF( ln_diaptr ) THEN 412 ! 413 IF( ln_subbas ) THEN 414 nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific 415 ALLOCATE( clsubb(nptr) ) 416 clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc' 417 ELSE 418 nptr = 1 ! Global only 419 ALLOCATE( clsubb(nptr) ) 420 clsubb(1) = 'glo' 421 ENDIF 422 423 ! ! allocate dia_ptr arrays 344 IF( l_diaptr ) THEN 345 ! 424 346 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 425 347 426 rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt 348 rc_pwatt = rc_pwatt * rho0_rcp ! conversion from K.s-1 to PetaWatt 349 rc_ggram = rc_ggram * rho0 ! conversion from m3/s to Gg/s 427 350 428 351 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 429 352 430 IF( ln_subbas ) THEN ! load sub-basin mask 431 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 432 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 433 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 434 CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin 435 CALL iom_close( inum ) 436 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 437 WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean 438 ELSE WHERE ; btm30(:,:) = ssmask(:,:) 439 END WHERE 440 ENDIF 441 442 btmsk(:,:,1) = tmask_i(:,:) ! global ocean 443 444 DO jn = 1, nptr 353 btmsk(:,:,1) = tmask_i(:,:) 354 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 355 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 356 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 357 CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin 358 CALL iom_close( inum ) 359 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 360 DO jn = 2, nptr 445 361 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 446 362 END DO 363 ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations 364 WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp) 365 zmsk(:,:) = 0._wp ! mask out Southern Ocean 366 ELSE WHERE 367 zmsk(:,:) = ssmask(:,:) 368 END WHERE 369 btmsk34(:,:,1) = btmsk(:,:,1) 370 DO jn = 2, nptr 371 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only 372 ENDDO 447 373 448 374 ! Initialise arrays to zero because diatpr is called before they are first calculated 449 375 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 450 htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp 451 htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp 452 htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp 453 htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp 454 htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp 376 hstr_adv(:,:,:) = 0._wp 377 hstr_ldf(:,:,:) = 0._wp 378 hstr_eiv(:,:,:) = 0._wp 379 hstr_ove(:,:,:) = 0._wp 380 hstr_btr(:,:,:) = 0._wp ! 381 hstr_vtr(:,:,:) = 0._wp ! 382 ! 383 ll_init = .FALSE. 455 384 ! 456 385 ENDIF … … 459 388 460 389 461 SUBROUTINE dia_ptr_hst( ktra, cptr, pv a)390 SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) 462 391 !!---------------------------------------------------------------------- 463 392 !! *** ROUTINE dia_ptr_hst *** … … 468 397 INTEGER , INTENT(in ) :: ktra ! tracer index 469 398 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 470 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pv a! 3D input array of advection/diffusion399 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion 471 400 INTEGER :: jn ! 472 401 402 ! 473 403 IF( cptr == 'adv' ) THEN 474 IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) ) 475 IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) ) 404 IF( ktra == jp_tem ) THEN 405 DO jn = 1, nptr 406 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 407 ENDDO 408 ENDIF 409 IF( ktra == jp_sal ) THEN 410 DO jn = 1, nptr 411 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 412 ENDDO 413 ENDIF 476 414 ENDIF 415 ! 477 416 IF( cptr == 'ldf' ) THEN 478 IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) ) 479 IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) ) 417 IF( ktra == jp_tem ) THEN 418 DO jn = 1, nptr 419 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 420 ENDDO 421 ENDIF 422 IF( ktra == jp_sal ) THEN 423 DO jn = 1, nptr 424 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 425 ENDDO 426 ENDIF 480 427 ENDIF 428 ! 481 429 IF( cptr == 'eiv' ) THEN 482 IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) ) 483 IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) ) 430 IF( ktra == jp_tem ) THEN 431 DO jn = 1, nptr 432 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 433 ENDDO 434 ENDIF 435 IF( ktra == jp_sal ) THEN 436 DO jn = 1, nptr 437 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 438 ENDDO 439 ENDIF 484 440 ENDIF 485 441 ! 486 IF( ln_subbas ) THEN 487 ! 488 IF( cptr == 'adv' ) THEN 489 IF( ktra == jp_tem ) THEN 490 DO jn = 2, nptr 491 htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 492 END DO 493 ENDIF 494 IF( ktra == jp_sal ) THEN 495 DO jn = 2, nptr 496 str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 497 END DO 498 ENDIF 499 ENDIF 500 IF( cptr == 'ldf' ) THEN 501 IF( ktra == jp_tem ) THEN 502 DO jn = 2, nptr 503 htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 504 END DO 505 ENDIF 506 IF( ktra == jp_sal ) THEN 507 DO jn = 2, nptr 508 str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 509 END DO 510 ENDIF 511 ENDIF 512 IF( cptr == 'eiv' ) THEN 513 IF( ktra == jp_tem ) THEN 514 DO jn = 2, nptr 515 htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 516 END DO 517 ENDIF 518 IF( ktra == jp_sal ) THEN 519 DO jn = 2, nptr 520 str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 521 END DO 522 ENDIF 523 ENDIF 524 ! 442 IF( cptr == 'vtr' ) THEN 443 IF( ktra == jp_tem ) THEN 444 DO jn = 1, nptr 445 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 446 ENDDO 447 ENDIF 448 IF( ktra == jp_sal ) THEN 449 DO jn = 1, nptr 450 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 451 ENDDO 452 ENDIF 525 453 ENDIF 454 ! 526 455 END SUBROUTINE dia_ptr_hst 527 456 … … 536 465 ierr(:) = 0 537 466 ! 538 ALLOCATE( btmsk(jpi,jpj,nptr) , & 539 & htr_adv(jpj,nptr) , str_adv(jpj,nptr) , & 540 & htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 541 & htr_ove(jpj,nptr) , str_ove(jpj,nptr) , & 542 & htr_btr(jpj,nptr) , str_btr(jpj,nptr) , & 543 & htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) ) 544 ! 545 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 546 ! 547 ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) ) 548 549 ! 550 dia_ptr_alloc = MAXVAL( ierr ) 551 CALL mpp_sum( 'diaptr', dia_ptr_alloc ) 467 IF( .NOT. ALLOCATED( btmsk ) ) THEN 468 ALLOCATE( btmsk(jpi,jpj,nptr) , btmsk34(jpi,jpj,nptr), & 469 & hstr_adv(jpj,jpts,nptr), hstr_eiv(jpj,jpts,nptr), & 470 & hstr_ove(jpj,jpts,nptr), hstr_btr(jpj,jpts,nptr), & 471 & hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) ) 472 ! 473 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 474 ! 475 dia_ptr_alloc = MAXVAL( ierr ) 476 CALL mpp_sum( 'diaptr', dia_ptr_alloc ) 477 ENDIF 552 478 ! 553 479 END FUNCTION dia_ptr_alloc 554 480 555 481 556 FUNCTION ptr_sj_3d( pv a, pmsk ) RESULT ( p_fval )482 FUNCTION ptr_sj_3d( pvflx, pmsk ) RESULT ( p_fval ) 557 483 !!---------------------------------------------------------------------- 558 484 !! *** ROUTINE ptr_sj_3d *** … … 560 486 !! ** Purpose : i-k sum computation of a j-flux array 561 487 !! 562 !! ** Method : - i-k sum of pv ausing the interior 2D vmask (vmask_i).563 !! pv ais supposed to be a masked flux (i.e. * vmask*e1v*e3v)564 !! 565 !! ** Action : - p_fval: i-k-mean poleward flux of pv a566 !!---------------------------------------------------------------------- 567 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva! mask flux array at V-point568 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL:: pmsk ! Optional 2D basin mask488 !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). 489 !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 490 !! 491 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 492 !!---------------------------------------------------------------------- 493 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvflx ! mask flux array at V-point 494 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 569 495 ! 570 496 INTEGER :: ji, jj, jk ! dummy loop arguments … … 577 503 ijpj = jpj 578 504 p_fval(:) = 0._wp 579 IF( PRESENT( pmsk ) ) THEN 580 DO jk = 1, jpkm1 581 DO jj = 2, jpjm1 582 DO ji = fs_2, fs_jpim1 ! Vector opt. 583 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj) 584 END DO 585 END DO 586 END DO 587 ELSE 588 DO jk = 1, jpkm1 589 DO jj = 2, jpjm1 590 DO ji = fs_2, fs_jpim1 ! Vector opt. 591 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 592 END DO 593 END DO 594 END DO 595 ENDIF 505 DO_3D_00_00( 1, jpkm1 ) 506 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 507 END_3D 596 508 #if defined key_mpp_mpi 597 509 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl) … … 601 513 602 514 603 FUNCTION ptr_sj_2d( pv a, pmsk ) RESULT ( p_fval )515 FUNCTION ptr_sj_2d( pvflx, pmsk ) RESULT ( p_fval ) 604 516 !!---------------------------------------------------------------------- 605 517 !! *** ROUTINE ptr_sj_2d *** 606 518 !! 607 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array608 !! 609 !! ** Method : - i-k sum of pv ausing the interior 2D vmask (vmask_i).610 !! pv ais supposed to be a masked flux (i.e. * vmask*e1v*e3v)611 !! 612 !! ** Action : - p_fval: i-k-mean poleward flux of pv a613 !!---------------------------------------------------------------------- 614 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva! mask flux array at V-point615 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL:: pmsk ! Optional 2D basin mask519 !! ** Purpose : "zonal" and vertical sum computation of a j-flux array 520 !! 521 !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). 522 !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 523 !! 524 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 525 !!---------------------------------------------------------------------- 526 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pvflx ! mask flux array at V-point 527 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 616 528 ! 617 529 INTEGER :: ji,jj ! dummy loop arguments … … 624 536 ijpj = jpj 625 537 p_fval(:) = 0._wp 626 IF( PRESENT( pmsk ) ) THEN 627 DO jj = 2, jpjm1 628 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 629 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj) 630 END DO 631 END DO 632 ELSE 633 DO jj = 2, jpjm1 634 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 635 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 636 END DO 637 END DO 638 ENDIF 538 DO_2D_00_00 539 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 540 END_2D 639 541 #if defined key_mpp_mpi 640 542 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl ) … … 643 545 END FUNCTION ptr_sj_2d 644 546 547 FUNCTION ptr_ci_2d( pva ) RESULT ( p_fval ) 548 !!---------------------------------------------------------------------- 549 !! *** ROUTINE ptr_ci_2d *** 550 !! 551 !! ** Purpose : "meridional" cumulated sum computation of a j-flux array 552 !! 553 !! ** Method : - j cumulated sum of pva using the interior 2D vmask (umask_i). 554 !! 555 !! ** Action : - p_fval: j-cumulated sum of pva 556 !!---------------------------------------------------------------------- 557 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 558 ! 559 INTEGER :: ji,jj,jc ! dummy loop arguments 560 INTEGER :: ijpj ! ??? 561 REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value 562 !!-------------------------------------------------------------------- 563 ! 564 ijpj = jpj ! ??? 565 p_fval(:,:) = 0._wp 566 DO jc = 1, jpnj ! looping over all processors in j axis 567 DO_2D_00_00 568 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 569 END_2D 570 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. ) 571 END DO 572 ! 573 END FUNCTION ptr_ci_2d 574 575 645 576 646 577 FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval ) … … 650 581 !! ** Purpose : i-sum computation of an array 651 582 !! 652 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).653 !! 654 !! ** Action : - p_fval: i- mean poleward flux of pva583 !! ** Method : - i-sum of field using the interior 2D vmask (pmsk). 584 !! 585 !! ** Action : - p_fval: i-sum of masked field 655 586 !!---------------------------------------------------------------------- 656 587 !! 657 588 IMPLICIT none 658 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) 659 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL:: pmsk ! Optional 2D basin mask589 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point 590 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 660 591 !! 661 592 INTEGER :: ji, jj, jk ! dummy loop arguments … … 673 604 p_fval(:,:) = 0._wp 674 605 ! 675 IF( PRESENT( pmsk ) ) THEN 676 DO jk = 1, jpkm1 677 DO jj = 2, jpjm1 678 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 679 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 680 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) 681 END DO 682 END DO 683 END DO 684 ELSE 685 DO jk = 1, jpkm1 686 DO jj = 2, jpjm1 687 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 688 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj) 689 END DO 690 END DO 691 END DO 692 END IF 606 DO_3D_00_00( 1, jpkm1 ) 607 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 608 END_3D 693 609 ! 694 610 #if defined key_mpp_mpi
Note: See TracChangeset
for help on using the changeset viewer.
