- Timestamp:
- 2015-07-15T17:46:12+02:00 (9 years ago)
- Location:
- branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA
- Files:
-
- 8 edited
-
diaar5.F90 (modified) (7 diffs)
-
diadct.F90 (modified) (5 diffs, 1 prop)
-
diafwb.F90 (modified) (5 diffs)
-
diaharm.F90 (modified) (2 diffs, 1 prop)
-
diahsb.F90 (modified) (4 diffs)
-
diahth.F90 (modified) (1 diff)
-
diaptr.F90 (modified) (10 diffs)
-
diawri.F90 (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r5034 r5600 21 21 USE timing ! preformance summary 22 22 USE wrk_nemo ! working arrays 23 USE fldread ! type FLD_N 24 USE phycst ! physical constant 25 USE in_out_manager ! I/O manager 23 26 24 27 IMPLICIT NONE … … 83 86 CALL wrk_alloc( jpi , jpj , jpk , jpts , ztsn ) 84 87 85 CALL iom_put( 'cellthc', fse3t(:,:,:) )86 87 88 zarea_ssh(:,:) = area(:,:) * sshn(:,:) 88 89 … … 105 106 END DO 106 107 IF( .NOT.lk_vvl ) THEN 107 DO ji=1,jpi 108 DO jj=1,jpj 109 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 110 END DO 111 END DO 108 IF ( ln_isfcav ) THEN 109 DO ji=1,jpi 110 DO jj=1,jpj 111 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 112 END DO 113 END DO 114 ELSE 115 zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 116 END IF 112 117 END IF 113 118 ! … … 127 132 END DO 128 133 IF( .NOT.lk_vvl ) THEN 129 DO ji=1,jpi 130 DO jj=1,jpj 131 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 132 END DO 133 END DO 134 IF ( ln_isfcav ) THEN 135 DO ji=1,jpi 136 DO jj=1,jpj 137 zbotpres(ji,jj) = zbotpres(ji,jj) + sshn(ji,jj) * zrhd(ji,jj,mikt(ji,jj)) + riceload(ji,jj) 138 END DO 139 END DO 140 ELSE 141 zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 142 END IF 134 143 END IF 135 144 ! … … 157 166 END DO 158 167 IF( .NOT.lk_vvl ) THEN 159 DO ji=1,jpi 160 DO jj=1,jpj 161 ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem) 162 zsal = zsal + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal) 163 END DO 164 END DO 168 IF ( ln_isfcav ) THEN 169 DO ji=1,jpi 170 DO jj=1,jpj 171 ztemp = ztemp + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_tem) 172 zsal = zsal + zarea_ssh(ji,jj) * tsn(ji,jj,mikt(ji,jj),jp_sal) 173 END DO 174 END DO 175 ELSE 176 ztemp = ztemp + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_tem) ) 177 zsal = zsal + SUM( zarea_ssh(:,:) * tsn(:,:,1,jp_sal) ) 178 END IF 165 179 ENDIF 166 180 IF( lk_mpp ) THEN … … 197 211 REAL(wp) :: zztmp 198 212 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 213 ! reading initial file 214 LOGICAL :: ln_tsd_init !: T & S data flag 215 LOGICAL :: ln_tsd_tradmp !: internal damping toward input data flag 216 CHARACTER(len=100) :: cn_dir 217 TYPE(FLD_N) :: sn_tem,sn_sal 218 INTEGER :: ios=0 219 220 NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 221 ! 222 223 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist : 224 READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 225 901 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 226 REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run 227 READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 228 902 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 229 IF(lwm) WRITE ( numond, namtsd ) 230 ! 199 231 !!---------------------------------------------------------------------- 200 232 ! … … 216 248 END DO 217 249 IF( lk_mpp ) CALL mpp_sum( vol0 ) 218 219 CALL iom_open ( 'data_1m_salinity_nomask', inum )220 CALL iom_get ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,1), 1 )221 CALL iom_get ( inum, jpdom_data, 'vosaline', zsaldta(:,:,:,2), 12 )250 251 CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 252 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1 ) 253 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 222 254 CALL iom_close( inum ) 223 255 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90
- Property svn:keywords set to Id
r4624 r5600 42 42 #endif 43 43 #if defined key_lim3 44 USE par_ice45 44 USE ice 46 45 #endif … … 113 112 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: transports_2d 114 113 114 !! $Id$ 115 115 CONTAINS 116 116 … … 176 176 177 177 !open output file 178 IF( lw p) THEN178 IF( lwm ) THEN 179 179 CALL ctl_opn( numdct_vol, 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 180 180 CALL ctl_opn( numdct_heat, 'heat_transport' , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) … … 283 283 DO jsec=1,nb_sec 284 284 285 IF( lw p)CALL dia_dct_wri(kt,jsec,secs(jsec))285 IF( lwm )CALL dia_dct_wri(kt,jsec,secs(jsec)) 286 286 287 287 !nullify transports values after writing … … 1298 1298 LOGICAL, PUBLIC, PARAMETER :: lk_diadct = .FALSE. !: diamht flag 1299 1299 PUBLIC 1300 !! $Id$ 1300 1301 CONTAINS 1301 1302 -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90
r5034 r5600 51 51 INTEGER, INTENT( in ) :: kt ! ocean time-step index 52 52 !! 53 INTEGER :: inum ! temporary logical unit 54 INTEGER :: ji, jj, jk, jt ! dummy loop indices 55 INTEGER :: ii0, ii1, ij0, ij1 56 REAL(wp) :: zarea, zvol, zwei 57 REAL(wp) :: ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 58 REAL(wp) :: zt, zs, zu 59 REAL(wp) :: zsm0, zfwfnew 53 INTEGER :: inum ! temporary logical unit 54 INTEGER :: ji, jj, jk, jt ! dummy loop indices 55 INTEGER :: ii0, ii1, ij0, ij1 56 INTEGER :: isrow ! index for ORCA1 starting row 57 REAL(wp) :: zarea, zvol, zwei 58 REAL(wp) :: ztemi(4), ztemo(4), zsali(4), zsalo(4), zflxi(4), zflxo(4) 59 REAL(wp) :: zt, zs, zu 60 REAL(wp) :: zsm0, zfwfnew 60 61 IF( cp_cfg == "orca" .AND. jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 61 62 !!---------------------------------------------------------------------- … … 165 166 CASE ( 1 ) ! ORCA_R1 configurations 166 167 ! ! ======================= 167 ii0 = 283 ; ii1 = 283 168 ij0 = 200 ; ij1 = 200 168 ! This dirty section will be suppressed by simplification process: 169 ! all this will come back in input files 170 ! Currently these hard-wired indices relate to configuration with 171 ! extend grid (jpjglo=332) 172 isrow = 332 - jpjglo 173 ! 174 ii0 = 283 ; ii1 = 283 175 ij0 = 241 - isrow ; ij1 = 241 - isrow 169 176 ! ! ======================= 170 177 CASE DEFAULT ! ORCA R05 or R025 … … 212 219 CASE ( 1 ) ! ORCA_R1 configurations 213 220 ! ! ======================= 214 ii0 = 282 ; ii1 = 282 215 ij0 = 200 ; ij1 = 200 221 ! This dirty section will be suppressed by simplification process: 222 ! all this will come back in input files 223 ! Currently these hard-wired indices relate to configuration with 224 ! extend grid (jpjglo=332) 225 isrow = 332 - jpjglo 226 ii0 = 282 ; ii1 = 282 227 ij0 = 240 - isrow ; ij1 = 240 - isrow 216 228 ! ! ======================= 217 229 CASE DEFAULT ! ORCA R05 or R025 … … 259 271 CASE ( 1 ) ! ORCA_R1 configurations 260 272 ! ! ======================= 261 ii0 = 331 ; ii1 = 331 262 ij0 = 176 ; ij1 = 176 273 ! This dirty section will be suppressed by simplification process: 274 ! all this will come back in input files 275 ! Currently these hard-wired indices relate to configuration with 276 ! extend grid (jpjglo=332) 277 isrow = 332 - jpjglo 278 ii0 = 331 ; ii1 = 331 279 ij0 = 215 - isrow ; ij1 = 215 - isrow 263 280 ! ! ======================= 264 281 CASE DEFAULT ! ORCA R05 or R025 … … 306 323 CASE ( 1 ) ! ORCA_R1 configurations 307 324 ! ! ======================= 308 ii0 = 297 ; ii1 = 297 309 ij0 = 230 ; ij1 = 230 325 ! This dirty section will be suppressed by simplification process: 326 ! all this will come back in input files 327 ! Currently these hard-wired indices relate to configuration with 328 ! extend grid (jpjglo=332) 329 isrow = 332 - jpjglo 330 ii0 = 297 ; ii1 = 297 331 ij0 = 269 - isrow ; ij1 = 269 - isrow 310 332 ! ! ======================= 311 333 CASE DEFAULT ! ORCA R05 or R025 -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90
- Property svn:keywords set to Id
r5034 r5600 60 60 !!---------------------------------------------------------------------- 61 61 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 62 !! $Id :$62 !! $Id$ 63 63 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 64 64 !!---------------------------------------------------------------------- … … 196 196 DO ji = 1,jpi 197 197 ! Elevation 198 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj) *tmask_i(ji,jj) 199 #if defined key_dynspg_ts 200 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 201 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 202 #endif 198 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj) 199 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 200 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 203 201 END DO 204 202 END DO -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90
r5034 r5600 96 96 z_frc_trd_t = glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) ) ! heat fluxes 97 97 z_frc_trd_s = glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) ) ! salt fluxes 98 ! Add runoff heat & salt input98 ! Add runoff heat & salt input 99 99 IF( ln_rnf ) z_frc_trd_t = z_frc_trd_t + glob_sum( rnf_tsc(:,:,jp_tem) * surf(:,:) ) 100 100 IF( ln_rnf_sal) z_frc_trd_s = z_frc_trd_s + glob_sum( rnf_tsc(:,:,jp_sal) * surf(:,:) ) 101 ! Add geothermal ice shelf101 ! Add ice shelf heat & salt input 102 102 IF( nn_isf .GE. 1 ) THEN 103 103 z_frc_trd_t = z_frc_trd_t & … … 112 112 ! 113 113 IF( .NOT. lk_vvl ) THEN 114 z2d0=0.0_wp ; z2d1=0.0_wp 115 DO ji=1,jpi 116 DO jj=1,jpj 117 z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 118 z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 114 IF ( ln_isfcav ) THEN 115 DO ji=1,jpi 116 DO jj=1,jpj 117 z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) 118 z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) 119 ENDDO 119 120 ENDDO 120 ENDDO 121 ELSE 122 z2d0(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_tem) 123 z2d1(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_sal) 124 END IF 121 125 z_wn_trd_t = - glob_sum( z2d0 ) 122 126 z_wn_trd_s = - glob_sum( z2d1 ) … … 144 148 ! heat & salt content variation (associated with ssh) 145 149 IF( .NOT. lk_vvl ) THEN 146 z2d0 = 0._wp ; z2d1 = 0._wp 147 DO ji = 1, jpi 148 DO jj = 1, jpj 149 z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) ) 150 z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) ) 150 IF ( ln_isfcav ) THEN 151 DO ji = 1, jpi 152 DO jj = 1, jpj 153 z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) ) 154 z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) ) 155 END DO 151 156 END DO 152 END DO 157 ELSE 158 z2d0(:,:) = surf(:,:) * ( tsn(:,:,1,jp_tem) * sshn(:,:) - ssh_hc_loc_ini(:,:) ) 159 z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) ) 160 END IF 153 161 z_ssh_hc = glob_sum( z2d0 ) 154 162 z_ssh_sc = glob_sum( z2d1 ) … … 277 285 frc_s = 0._wp ! salt content - - - - 278 286 IF( .NOT. lk_vvl ) THEN 279 DO ji=1,jpi 280 DO jj=1,jpj 281 ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) ! initial heat content in ssh 282 ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) ! initial salt content in ssh 287 IF ( ln_isfcav ) THEN 288 DO ji=1,jpi 289 DO jj=1,jpj 290 ssh_hc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) ! initial heat content in ssh 291 ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) ! initial salt content in ssh 292 ENDDO 283 293 ENDDO 284 ENDDO 294 ELSE 295 ssh_hc_loc_ini(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) ! initial heat content in ssh 296 ssh_sc_loc_ini(:,:) = tsn(:,:,1,jp_sal) * sshn(:,:) ! initial salt content in ssh 297 END IF 285 298 frc_wn_t = 0._wp ! initial heat content misfit due to free surface 286 299 frc_wn_s = 0._wp ! initial salt content misfit due to free surface -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90
r4292 r5600 245 245 CALL iom_put( "mldr10_3", zrho10_3 ) ! MLD delta rho(10m) = 0.03 246 246 CALL iom_put( "pycndep" , zpycn ) ! MLD delta rho equi. delta T(10m) = 0.2 247 CALL iom_put( "BLT" , ztm2 - zpycn ) ! Barrier Layer Thickness248 247 CALL iom_put( "tinv" , ztinv ) ! max. temp. inv. (t10 ref) 249 248 CALL iom_put( "depti" , zdepinv ) ! depth of max. temp. inv. (t10 ref) -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r5034 r5600 8 8 !! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields 9 9 !! 3.3 ! 2010-10 (G. Madec) dynamical allocation 10 !! 3.6 ! 2014-12 (C. Ethe) use of IOM 10 11 !!---------------------------------------------------------------------- 11 12 … … 13 14 !! dia_ptr : Poleward Transport Diagnostics module 14 15 !! dia_ptr_init : Initialization, namelist read 15 !! dia_ptr_wri : Output of poleward fluxes 16 !! ptr_vjk : "zonal" sum computation of a "meridional" flux array 17 !! ptr_tjk : "zonal" mean computation of a tracer field 18 !! ptr_vj : "zonal" and vertical sum computation of a "meridional" flux array 19 !! (Generic interface to ptr_vj_3d, ptr_vj_2d) 16 !! ptr_sjk : "zonal" mean computation of a field - tracer or flux array 17 !! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array 18 !! (Generic interface to ptr_sj_3d, ptr_sj_2d) 20 19 !!---------------------------------------------------------------------- 21 20 USE oce ! ocean dynamics and active tracers 22 21 USE dom_oce ! ocean space and time domain 23 22 USE phycst ! physical constants 24 USE ldftra_oce ! ocean active tracers: lateral physics 25 USE dianam ! 23 ! 26 24 USE iom ! IOM library 27 USE ioipsl ! IO-IPSL library28 25 USE in_out_manager ! I/O manager 29 26 USE lib_mpp ! MPP library 30 USE lbclnk ! lateral boundary condition - processor exchanges31 27 USE timing ! preformance summary 32 USE wrk_nemo ! working arrays33 28 34 29 IMPLICIT NONE 35 30 PRIVATE 36 31 37 INTERFACE ptr_ vj38 MODULE PROCEDURE ptr_ vj_3d, ptr_vj_2d32 INTERFACE ptr_sj 33 MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 39 34 END INTERFACE 40 35 41 PUBLIC dia_ptr_init ! call in opa module 36 PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines 37 PUBLIC ptr_sjk ! 38 PUBLIC dia_ptr_init ! call in step module 42 39 PUBLIC dia_ptr ! call in step module 43 PUBLIC ptr_vj ! call by tra_ldf & tra_adv routines44 PUBLIC ptr_vjk ! call by tra_ldf & tra_adv routines45 40 46 41 ! !!** namelist namptr ** 47 LOGICAL , PUBLIC :: ln_diaptr !: Poleward transport flag (T) or not (F) 48 LOGICAL , PUBLIC :: ln_subbas !: Atlantic/Pacific/Indian basins calculation 49 LOGICAL , PUBLIC :: ln_diaznl !: Add zonal means and meridional stream functions 50 LOGICAL , PUBLIC :: ln_ptrcomp !: Add decomposition : overturning (and gyre, soon ...) 51 INTEGER , PUBLIC :: nn_fptr !: frequency of ptr computation [time step] 52 INTEGER , PUBLIC :: nn_fwri !: frequency of ptr outputs [time step] 53 54 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.) 55 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.) 42 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf !: Heat TRansports (adv, diff, overturn.) 43 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf !: Salt TRansports (adv, diff, overturn.) 56 44 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr , str ! adv heat and salt transports (approx) 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 62 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 63 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 64 65 66 INTEGER :: niter ! 67 INTEGER :: nidom_ptr ! 68 INTEGER :: numptr ! logical unit for Poleward TRansports 69 INTEGER :: nptr ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T) 45 46 LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) 47 LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation 48 INTEGER :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T) 70 49 71 50 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 73 52 REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg 74 53 75 REAL(wp), TARGET, DIMENSION(:), ALLOCATABLE, SAVE :: p_fval1d 76 REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d 77 78 !! Integer, 1D workspace arrays. Not common enough to be implemented in 79 !! wrk_nemo module. 80 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc 81 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 82 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 54 CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:) :: clsubb 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 57 58 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d 59 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 60 83 61 84 62 !! * Substitutions … … 92 70 CONTAINS 93 71 94 FUNCTION dia_ptr_alloc() 95 !!---------------------------------------------------------------------- 96 !! *** ROUTINE dia_ptr_alloc *** 97 !!---------------------------------------------------------------------- 98 INTEGER :: dia_ptr_alloc ! return value 99 INTEGER, DIMENSION(6) :: ierr 100 !!---------------------------------------------------------------------- 101 ierr(:) = 0 102 ! 103 ALLOCATE( btmsk(jpi,jpj,nptr) , & 104 & htr_adv(jpj) , str_adv(jpj) , & 105 & htr_ldf(jpj) , str_ldf(jpj) , & 106 & htr_ove(jpj) , str_ove(jpj), & 107 & htr(jpj,nptr) , str(jpj,nptr) , & 108 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 109 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1) ) 110 ! 111 #if defined key_diaeiv 112 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 113 & v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 114 #endif 115 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3)) 116 ! 117 ALLOCATE(ndex(jpj*jpk), ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 118 & ndex_ind(jpj*jpk), ndex_ipc(jpj*jpk), & 119 & ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 120 121 ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk), & 122 & ndex_h(jpj), ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 123 & ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5) ) 124 ! 125 ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6) ) 126 ! 127 dia_ptr_alloc = MAXVAL( ierr ) 128 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) 129 ! 130 END FUNCTION dia_ptr_alloc 131 132 133 FUNCTION ptr_vj_3d( pva ) RESULT ( p_fval ) 134 !!---------------------------------------------------------------------- 135 !! *** ROUTINE ptr_vj_3d *** 136 !! 137 !! ** Purpose : i-k sum computation of a j-flux array 138 !! 139 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 140 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 141 !! 142 !! ** Action : - p_fval: i-k-mean poleward flux of pva 143 !!---------------------------------------------------------------------- 144 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 145 !! 146 INTEGER :: ji, jj, jk ! dummy loop arguments 147 INTEGER :: ijpj ! ??? 148 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 149 !!-------------------------------------------------------------------- 150 ! 151 p_fval => p_fval1d 152 153 ijpj = jpj 154 p_fval(:) = 0._wp 155 DO jk = 1, jpkm1 156 DO jj = 2, jpjm1 157 DO ji = fs_2, fs_jpim1 ! Vector opt. 158 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 159 END DO 160 END DO 161 END DO 162 #if defined key_mpp_mpi 163 IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl) 164 #endif 165 ! 166 END FUNCTION ptr_vj_3d 167 168 169 FUNCTION ptr_vj_2d( pva ) RESULT ( p_fval ) 170 !!---------------------------------------------------------------------- 171 !! *** ROUTINE ptr_vj_2d *** 172 !! 173 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array 174 !! 175 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 176 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 177 !! 178 !! ** Action : - p_fval: i-k-mean poleward flux of pva 179 !!---------------------------------------------------------------------- 180 IMPLICIT none 181 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 182 !! 183 INTEGER :: ji,jj ! dummy loop arguments 184 INTEGER :: ijpj ! ??? 185 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 186 !!-------------------------------------------------------------------- 187 ! 188 p_fval => p_fval1d 189 190 ijpj = jpj 191 p_fval(:) = 0._wp 192 DO jj = 2, jpjm1 193 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 194 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 195 END DO 196 END DO 197 #if defined key_mpp_mpi 198 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 199 #endif 200 ! 201 END FUNCTION ptr_vj_2d 202 203 204 FUNCTION ptr_vjk( pva, pmsk ) RESULT ( p_fval ) 205 !!---------------------------------------------------------------------- 206 !! *** ROUTINE ptr_vjk *** 207 !! 208 !! ** Purpose : i-sum computation of a j-velocity array 209 !! 210 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i). 211 !! pva is supposed to be a masked flux (i.e. * vmask) 212 !! 213 !! ** Action : - p_fval: i-mean poleward flux of pva 214 !!---------------------------------------------------------------------- 215 !! 216 IMPLICIT none 217 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 218 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 219 !! 220 INTEGER :: ji, jj, jk ! dummy loop arguments 221 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 222 #if defined key_mpp_mpi 223 INTEGER, DIMENSION(1) :: ish 224 INTEGER, DIMENSION(2) :: ish2 225 INTEGER :: ijpjjpk 226 #endif 227 #if defined key_mpp_mpi 228 REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point 229 #endif 230 !!-------------------------------------------------------------------- 231 ! 232 #if defined key_mpp_mpi 233 ijpjjpk = jpj*jpk 234 CALL wrk_alloc( jpj*jpk, zwork ) 235 #endif 236 237 p_fval => p_fval2d 238 239 p_fval(:,:) = 0._wp 240 ! 241 IF( PRESENT( pmsk ) ) THEN 242 DO jk = 1, jpkm1 243 DO jj = 2, jpjm1 244 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 245 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 246 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj) 72 SUBROUTINE dia_ptr( pvtr ) 73 !!---------------------------------------------------------------------- 74 !! *** ROUTINE dia_ptr *** 75 !!---------------------------------------------------------------------- 76 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 77 ! 78 INTEGER :: ji, jj, jk, jn ! dummy loop indices 79 REAL(wp) :: zv, zsfc ! local scalar 80 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 81 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace 83 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace 84 CHARACTER( len = 10 ) :: cl1 85 !!---------------------------------------------------------------------- 86 ! 87 IF( nn_timing == 1 ) CALL timing_start('dia_ptr') 88 89 ! 90 IF( PRESENT( pvtr ) ) THEN 91 IF( iom_use("zomsfglo") ) THEN ! effective MSF 92 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) ) ! zonal cumulative effective transport 93 DO jk = 2, jpkm1 94 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 95 END DO 96 DO ji = 1, jpi 97 z3d(ji,:,:) = z3d(1,:,:) 98 ENDDO 99 cl1 = TRIM('zomsf'//clsubb(1) ) 100 CALL iom_put( cl1, z3d * rc_sv ) 101 DO jn = 2, nptr ! by sub-basins 102 z3d(1,:,:) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 103 DO jk = 2, jpkm1 104 z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF) 247 105 END DO 248 END DO 249 END DO 250 ELSE 251 DO jk = 1, jpkm1 252 DO jj = 2, jpjm1 253 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 254 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj) 255 END DO 256 END DO 257 END DO 258 END IF 259 ! 260 #if defined key_mpp_mpi 261 ijpjjpk = jpj*jpk 262 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 263 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 264 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 265 p_fval(:,:) = RESHAPE( zwork, ish2 ) 266 #endif 267 ! 268 #if defined key_mpp_mpi 269 CALL wrk_dealloc( jpj*jpk, zwork ) 270 #endif 271 ! 272 END FUNCTION ptr_vjk 273 274 275 FUNCTION ptr_tjk( pta, pmsk ) RESULT ( p_fval ) 276 !!---------------------------------------------------------------------- 277 !! *** ROUTINE ptr_tjk *** 278 !! 279 !! ** Purpose : i-sum computation of e1t*e3t * a tracer field 280 !! 281 !! ** Method : - i-sum of mj(pta) using tmask 282 !! 283 !! ** Action : - p_fval: i-sum of e1t*e3t*pta 284 !!---------------------------------------------------------------------- 285 !! 286 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point 287 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 288 !! 289 INTEGER :: ji, jj, jk ! dummy loop arguments 290 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 291 #if defined key_mpp_mpi 292 INTEGER, DIMENSION(1) :: ish 293 INTEGER, DIMENSION(2) :: ish2 294 INTEGER :: ijpjjpk 295 #endif 296 #if defined key_mpp_mpi 297 REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point 298 #endif 299 !!-------------------------------------------------------------------- 300 ! 301 #if defined key_mpp_mpi 302 ijpjjpk = jpj*jpk 303 CALL wrk_alloc( jpj*jpk, zwork ) 304 #endif 305 306 p_fval => p_fval2d 307 308 p_fval(:,:) = 0._wp 309 DO jk = 1, jpkm1 310 DO jj = 2, jpjm1 311 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 312 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj) 313 END DO 314 END DO 315 END DO 316 #if defined key_mpp_mpi 317 ijpjjpk = jpj*jpk 318 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 319 zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 320 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 321 p_fval(:,:)= RESHAPE( zwork, ish2 ) 322 #endif 323 ! 324 #if defined key_mpp_mpi 325 CALL wrk_dealloc( jpj*jpk, zwork ) 326 #endif 327 ! 328 END FUNCTION ptr_tjk 329 330 331 SUBROUTINE dia_ptr( kt ) 332 !!---------------------------------------------------------------------- 333 !! *** ROUTINE dia_ptr *** 334 !!---------------------------------------------------------------------- 335 USE oce, vt => ua ! use ua as workspace 336 USE oce, vs => va ! use va as workspace 337 IMPLICIT none 338 !! 339 INTEGER, INTENT(in) :: kt ! ocean time step index 340 ! 341 INTEGER :: ji, jj, jk, jn ! dummy loop indices 342 REAL(wp) :: zv ! local scalar 343 !!---------------------------------------------------------------------- 344 ! 345 IF( nn_timing == 1 ) CALL timing_start('dia_ptr') 346 ! 347 IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 ) THEN 348 ! 349 IF( MOD( kt, nn_fptr ) == 0 ) THEN 350 ! 351 IF( ln_diaznl ) THEN ! i-mean temperature and salinity 352 DO jn = 1, nptr 353 tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 354 sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 355 END DO 356 ENDIF 357 ! 358 ! ! horizontal integral and vertical dz 359 ! ! eulerian velocity 360 v_msf(:,:,1) = ptr_vjk( vn(:,:,:) ) 361 DO jn = 2, nptr 362 v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 363 END DO 364 #if defined key_diaeiv 365 DO jn = 1, nptr ! bolus velocity 366 v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) ) ! here no btm30 for MSFeiv 367 END DO 368 ! ! add bolus stream-function to the eulerian one 369 v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:) 370 #endif 371 ! 372 ! ! Transports 373 ! ! local heat & salt transports at T-points ( tsn*mj[vn+v_eiv] ) 374 vt(:,:,jpk) = 0._wp ; vs(:,:,jpk) = 0._wp 375 DO jk= 1, jpkm1 376 DO jj = 2, jpj 106 DO ji = 1, jpi 107 z3d(ji,:,:) = z3d(1,:,:) 108 ENDDO 109 cl1 = TRIM('zomsf'//clsubb(jn) ) 110 CALL iom_put( cl1, z3d * rc_sv ) 111 END DO 112 ENDIF 113 ! 114 ELSE 115 ! 116 IF( iom_use("zotemglo") ) THEN ! i-mean i-k-surface 117 DO jk = 1, jpkm1 118 DO jj = 1, jpj 377 119 DO ji = 1, jpi 378 #if defined key_diaeiv 379 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + v_eiv(ji,jj,jk) + v_eiv(ji,jj-1,jk) ) * 0.5_wp 380 #else 381 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 382 #endif 383 vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem) 384 vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal) 385 END DO 386 END DO 387 END DO 388 !!gm useless as overlap areas are not used in ptr_vjk 389 CALL lbc_lnk( vs, 'V', -1. ) ; CALL lbc_lnk( vt, 'V', -1. ) 390 !!gm 391 ! ! heat & salt advective transports (approximation) 392 htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt ! SUM over jk + conversion 393 str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram 394 DO jn = 2, nptr 395 htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_pwatt ! mask Southern Ocean 396 str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_ggram ! mask Southern Ocean 397 END DO 398 399 IF( ln_ptrcomp ) THEN ! overturning transport 400 htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt ! SUM over jk + conversion 401 str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram 402 END IF 403 ! ! Advective and diffusive transport 404 htr_adv(:) = htr_adv(:) * rc_pwatt ! these are computed in tra_adv... and tra_ldf... routines 405 htr_ldf(:) = htr_ldf(:) * rc_pwatt ! here just the conversion in PW and Gg 406 str_adv(:) = str_adv(:) * rc_ggram 407 str_ldf(:) = str_ldf(:) * rc_ggram 408 409 #if defined key_diaeiv 410 DO jn = 1, nptr ! Bolus component 411 htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt ! SUM over jk 412 str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram ! SUM over jk 413 END DO 414 #endif 415 ! ! "Meridional" Stream-Function 120 zsfc = e1t(ji,jj) * fse3t(ji,jj,jk) 121 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 122 zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc 123 zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc 124 ENDDO 125 ENDDO 126 ENDDO 416 127 DO jn = 1, nptr 417 DO jk = 2, jpk 418 v_msf (:,jk,jn) = v_msf (:,jk-1,jn) + v_msf (:,jk,jn) ! Eulerian j-Stream-Function 419 #if defined key_diaeiv 420 v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn) ! Bolus j-Stream-Function 421 422 #endif 423 END DO 424 END DO 425 v_msf (:,:,:) = v_msf (:,:,:) * rc_sv ! converte in Sverdrups 426 #if defined key_diaeiv 427 v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv 428 #endif 429 ENDIF 430 ! 431 CALL dia_ptr_wri( kt ) ! outputs 128 zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 129 cl1 = TRIM('zosrf'//clsubb(jn) ) 130 CALL iom_put( cl1, zmask ) 131 ! 132 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 133 & / MAX( zmask(1,:,:), 10.e-15 ) 134 DO ji = 1, jpi 135 z3d(ji,:,:) = z3d(1,:,:) 136 ENDDO 137 cl1 = TRIM('zotem'//clsubb(jn) ) 138 CALL iom_put( cl1, z3d ) 139 ! 140 z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 141 & / MAX( zmask(1,:,:), 10.e-15 ) 142 DO ji = 1, jpi 143 z3d(ji,:,:) = z3d(1,:,:) 144 ENDDO 145 cl1 = TRIM('zosal'//clsubb(jn) ) 146 CALL iom_put( cl1, z3d ) 147 END DO 148 ENDIF 149 ! 150 ! ! Advective and diffusive heat and salt transport 151 IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN 152 z2d(1,:) = htr_adv(:) * rc_pwatt ! (conversion in PW) 153 DO ji = 1, jpi 154 z2d(ji,:) = z2d(1,:) 155 ENDDO 156 cl1 = 'sophtadv' 157 CALL iom_put( TRIM(cl1), z2d ) 158 z2d(1,:) = str_adv(:) * rc_ggram ! (conversion in Gg) 159 DO ji = 1, jpi 160 z2d(ji,:) = z2d(1,:) 161 ENDDO 162 cl1 = 'sopstadv' 163 CALL iom_put( TRIM(cl1), z2d ) 164 ENDIF 165 ! 166 IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN 167 z2d(1,:) = htr_ldf(:) * rc_pwatt ! (conversion in PW) 168 DO ji = 1, jpi 169 z2d(ji,:) = z2d(1,:) 170 ENDDO 171 cl1 = 'sophtldf' 172 CALL iom_put( TRIM(cl1), z2d ) 173 z2d(1,:) = str_ldf(:) * rc_ggram ! (conversion in Gg) 174 DO ji = 1, jpi 175 z2d(ji,:) = z2d(1,:) 176 ENDDO 177 cl1 = 'sopstldf' 178 CALL iom_put( TRIM(cl1), z2d ) 179 ENDIF 432 180 ! 433 181 ENDIF 434 !435 #if defined key_mpp_mpi436 IF( kt == nitend .AND. l_znl_root ) CALL histclo( numptr ) ! Close the file437 #else438 IF( kt == nitend ) CALL histclo( numptr ) ! Close the file439 #endif440 182 ! 441 183 IF( nn_timing == 1 ) CALL timing_stop('dia_ptr') … … 450 192 !! ** Purpose : Initialization, namelist read 451 193 !!---------------------------------------------------------------------- 452 INTEGER :: jn ! dummy loop indices 453 INTEGER :: inum, ierr ! local integers 454 INTEGER :: ios ! Local integer output status for namelist read 455 #if defined key_mpp_mpi 456 INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 457 #endif 458 !! 459 NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 194 INTEGER :: jn ! local integers 195 INTEGER :: inum, ierr ! local integers 196 INTEGER :: ios ! Local integer output status for namelist read 197 !! 198 NAMELIST/namptr/ ln_diaptr, ln_subbas 460 199 !!---------------------------------------------------------------------- 461 200 … … 475 214 WRITE(numout,*) ' Namelist namptr : set ptr parameters' 476 215 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr 477 WRITE(numout,*) ' Overturning heat & salt transport ln_ptrcomp = ', ln_ptrcomp478 WRITE(numout,*) ' T & S zonal mean and meridional stream function ln_diaznl = ', ln_diaznl479 216 WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas 480 WRITE(numout,*) ' Frequency of computation nn_fptr = ', nn_fptr481 WRITE(numout,*) ' Frequency of outputs nn_fwri = ', nn_fwri482 217 ENDIF 483 484 IF( ln_diaptr) THEN 485 486 IF( nn_timing == 1 ) CALL timing_start('dia_ptr_init') 487 488 IF( ln_subbas ) THEN ; nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific 489 ELSE ; nptr = 1 ! Global only 218 219 IF( ln_diaptr ) THEN 220 ! 221 IF( ln_subbas ) THEN 222 nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific 223 ALLOCATE( clsubb(nptr) ) 224 clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc' 225 ELSE 226 nptr = 1 ! Global only 227 ALLOCATE( clsubb(nptr) ) 228 clsubb(1) = 'glo' 490 229 ENDIF 491 230 … … 493 232 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 494 233 495 rc_pwatt = rc_pwatt * rau0 *rcp ! conversion from K.s-1 to PetaWatt234 rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt 496 235 497 236 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 498 237 499 238 IF( ln_subbas ) THEN ! load sub-basin mask 500 CALL iom_open( 'subbasins', inum )239 CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) 501 240 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 502 241 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin … … 508 247 END WHERE 509 248 ENDIF 249 510 250 btmsk(:,:,1) = tmask_i(:,:) ! global ocean 511 251 … … 513 253 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 514 254 END DO 515 516 IF( lk_vvl ) CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' ) 517 518 ! ! i-sum of e1v*e3v surface and its inverse 519 DO jn = 1, nptr 520 sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) ) 521 r1_sjk(:,:,jn) = 0._wp 522 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 523 END DO 524 525 ! Initialise arrays to zero because diatpr is called before they are first calculated 526 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 527 htr_adv(:) = 0._wp ; str_adv(:) = 0._wp ; htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp 528 529 #if defined key_mpp_mpi 530 iglo (1) = jpjglo ! MPP case using MPI ('key_mpp_mpi') 531 iloc (1) = nlcj 532 iabsf(1) = njmppt(narea) 533 iabsl(:) = iabsf(:) + iloc(:) - 1 534 ihals(1) = nldj - 1 535 ihale(1) = nlcj - nlej 536 idid (1) = 2 537 CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr ) 538 #else 539 nidom_ptr = FLIO_DOM_NONE 540 #endif 541 IF( nn_timing == 1 ) CALL timing_stop('dia_ptr_init') 542 ! 255 256 ! Initialise arrays to zero because diatpr is called before they are first calculated 257 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 258 htr_adv(:) = 0._wp ; str_adv(:) = 0._wp 259 htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp 260 ! 543 261 ENDIF 544 262 ! … … 546 264 547 265 548 SUBROUTINE dia_ptr_wri( kt ) 549 !!--------------------------------------------------------------------- 550 !! *** ROUTINE dia_ptr_wri *** 551 !! 552 !! ** Purpose : output of poleward fluxes 553 !! 554 !! ** Method : NetCDF file 555 !!---------------------------------------------------------------------- 556 !! 557 INTEGER, INTENT(in) :: kt ! ocean time-step index 558 !! 559 INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw 560 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc 561 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30 562 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 563 !! 564 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 565 INTEGER :: iline, it, itmod, ji, jj, jk ! 566 #if defined key_iomput 567 INTEGER :: inum ! temporary logical unit 266 FUNCTION dia_ptr_alloc() 267 !!---------------------------------------------------------------------- 268 !! *** ROUTINE dia_ptr_alloc *** 269 !!---------------------------------------------------------------------- 270 INTEGER :: dia_ptr_alloc ! return value 271 INTEGER, DIMENSION(3) :: ierr 272 !!---------------------------------------------------------------------- 273 ierr(:) = 0 274 ! 275 ALLOCATE( btmsk(jpi,jpj,nptr) , & 276 & htr_adv(jpj) , str_adv(jpj) , & 277 & htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1) ) 278 ! 279 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 280 ! 281 ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) ) 282 283 ! 284 dia_ptr_alloc = MAXVAL( ierr ) 285 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) 286 ! 287 END FUNCTION dia_ptr_alloc 288 289 290 FUNCTION ptr_sj_3d( pva, pmsk ) RESULT ( p_fval ) 291 !!---------------------------------------------------------------------- 292 !! *** ROUTINE ptr_sj_3d *** 293 !! 294 !! ** Purpose : i-k sum computation of a j-flux array 295 !! 296 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 297 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 298 !! 299 !! ** Action : - p_fval: i-k-mean poleward flux of pva 300 !!---------------------------------------------------------------------- 301 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 302 REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask 303 ! 304 INTEGER :: ji, jj, jk ! dummy loop arguments 305 INTEGER :: ijpj ! ??? 306 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 307 !!-------------------------------------------------------------------- 308 ! 309 p_fval => p_fval1d 310 311 ijpj = jpj 312 p_fval(:) = 0._wp 313 IF( PRESENT( pmsk ) ) THEN 314 DO jk = 1, jpkm1 315 DO jj = 2, jpjm1 316 DO ji = fs_2, fs_jpim1 ! Vector opt. 317 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj) 318 END DO 319 END DO 320 END DO 321 ELSE 322 DO jk = 1, jpkm1 323 DO jj = 2, jpjm1 324 DO ji = fs_2, fs_jpim1 ! Vector opt. 325 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 326 END DO 327 END DO 328 END DO 329 ENDIF 330 #if defined key_mpp_mpi 331 IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl) 568 332 #endif 569 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 570 !! 571 REAL(wp), POINTER, DIMENSION(:) :: zphi, zfoo ! 1D workspace 572 REAL(wp), POINTER, DIMENSION(:,:) :: z_1 ! 2D workspace 573 !!-------------------------------------------------------------------- 574 ! 575 CALL wrk_alloc( jpj , zphi , zfoo ) 576 CALL wrk_alloc( jpj , jpk , z_1 ) 577 578 ! define time axis 579 it = kt / nn_fptr 580 itmod = kt - nit000 + 1 581 582 ! Initialization 583 ! -------------- 584 IF( kt == nit000 ) THEN 585 niter = ( nit000 - 1 ) / nn_fptr 586 zdt = rdt 587 IF( nacc == 1 ) zdt = rdtmin 588 ! 589 IF(lwp) THEN 590 WRITE(numout,*) 591 WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter 592 WRITE(numout,*) '~~~~~~~~~~~~' 593 ENDIF 594 595 ! Reference latitude (used in plots) 596 ! ------------------ 597 ! ! ======================= 598 IF( cp_cfg == "orca" ) THEN ! ORCA configurations 599 ! ! ======================= 600 IF( jp_cfg == 05 ) iline = 192 ! i-line that passes near the North Pole 601 IF( jp_cfg == 025 ) iline = 384 ! i-line that passes near the North Pole 602 IF( jp_cfg == 1 ) iline = 96 ! i-line that passes near the North Pole 603 IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole 604 IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole 605 zphi(1:jpj) = 0._wp 606 DO ji = mi0(iline), mi1(iline) 607 zphi(1:jpj) = gphiv(ji,:) ! if iline is in the local domain 608 ! Correct highest latitude for some configurations - will work if domain is parallelized in J ? 609 IF( jp_cfg == 05 ) THEN 610 DO jj = mj0(jpjdta), mj1(jpjdta) 611 zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp 612 zphi( jj ) = MIN( zphi(jj), 90._wp ) 613 END DO 614 END IF 615 IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 616 DO jj = mj0(jpjdta-1), mj1(jpjdta-1) 617 zphi( jj ) = 88.5_wp 618 END DO 619 DO jj = mj0(jpjdta ), mj1(jpjdta ) 620 zphi( jj ) = 89.5_wp 621 END DO 622 END IF 623 END DO 624 ! provide the correct zphi to all local domains 333 ! 334 END FUNCTION ptr_sj_3d 335 336 337 FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval ) 338 !!---------------------------------------------------------------------- 339 !! *** ROUTINE ptr_sj_2d *** 340 !! 341 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array 342 !! 343 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). 344 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 345 !! 346 !! ** Action : - p_fval: i-k-mean poleward flux of pva 347 !!---------------------------------------------------------------------- 348 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 349 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask 350 ! 351 INTEGER :: ji,jj ! dummy loop arguments 352 INTEGER :: ijpj ! ??? 353 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 354 !!-------------------------------------------------------------------- 355 ! 356 p_fval => p_fval1d 357 358 ijpj = jpj 359 p_fval(:) = 0._wp 360 IF( PRESENT( pmsk ) ) THEN 361 DO jj = 2, jpjm1 362 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 363 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj) 364 END DO 365 END DO 366 ELSE 367 DO jj = 2, jpjm1 368 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 369 p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) 370 END DO 371 END DO 372 ENDIF 625 373 #if defined key_mpp_mpi 626 CALL mpp_sum( zphi, jpj, ncomm_znl )374 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 627 375 #endif 628 ! ! ======================= 629 ELSE ! OTHER configurations 630 ! ! ======================= 631 zphi(1:jpj) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line 632 ! 633 ENDIF 634 ! 635 ! Work only on westmost processor (will not work if mppini2 is used) 376 ! 377 END FUNCTION ptr_sj_2d 378 379 380 FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval ) 381 !!---------------------------------------------------------------------- 382 !! *** ROUTINE ptr_sjk *** 383 !! 384 !! ** Purpose : i-sum computation of an array 385 !! 386 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i). 387 !! 388 !! ** Action : - p_fval: i-mean poleward flux of pva 389 !!---------------------------------------------------------------------- 390 !! 391 IMPLICIT none 392 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point 393 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 394 !! 395 INTEGER :: ji, jj, jk ! dummy loop arguments 396 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 636 397 #if defined key_mpp_mpi 637 IF( l_znl_root ) THEN 398 INTEGER, DIMENSION(1) :: ish 399 INTEGER, DIMENSION(2) :: ish2 400 INTEGER :: ijpjjpk 401 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point 638 402 #endif 639 ! 640 ! OPEN netcdf file 641 ! ---------------- 642 ! Define frequency of output and means 643 zsto = nn_fptr * zdt 644 IF( ln_mskland ) THEN ! put 1.e+20 on land (very expensive!!) 645 clop = "ave(only(x))" 646 clop_once = "once(only(x))" 647 ELSE ! no use of the mask value (require less cpu time) 648 clop = "ave(x)" 649 clop_once = "once" 650 ENDIF 651 652 zout = nn_fwri * zdt 653 zfoo(1:jpj) = 0._wp 654 655 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) ! Compute julian date from starting date of the run 656 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 657 658 #if defined key_iomput 659 ! Requested by IPSL people, use by their postpro... 660 IF(lwp) THEN 661 CALL dia_nam( clhstnam, nn_fwri,' ' ) 662 CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 663 WRITE(inum,*) clhstnam 664 CLOSE(inum) 665 ENDIF 403 !!-------------------------------------------------------------------- 404 ! 405 p_fval => p_fval2d 406 407 p_fval(:,:) = 0._wp 408 ! 409 IF( PRESENT( pmsk ) ) THEN 410 DO jk = 1, jpkm1 411 DO jj = 2, jpjm1 412 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 413 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 414 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) 415 END DO 416 END DO 417 END DO 418 ELSE 419 DO jk = 1, jpkm1 420 DO jj = 2, jpjm1 421 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 422 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj) 423 END DO 424 END DO 425 END DO 426 END IF 427 ! 428 #if defined key_mpp_mpi 429 ijpjjpk = jpj*jpk 430 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 431 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 432 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 433 p_fval(:,:) = RESHAPE( zwork, ish2 ) 666 434 #endif 667 668 CALL dia_nam( clhstnam, nn_fwri, 'diaptr' ) 669 IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam 670 671 ! Horizontal grid : zphi() 672 CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, & 673 1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr) 674 ! Vertical grids : gdept_1d, gdepw_1d 675 CALL histvert( numptr, "deptht", "Vertical T levels", & 676 & "m", jpk, gdept_1d, ndepidzt, "down" ) 677 CALL histvert( numptr, "depthw", "Vertical W levels", & 678 & "m", jpk, gdepw_1d, ndepidzw, "down" ) 679 ! 680 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth 681 CALL wheneq ( jpj , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h ) ! Lat 682 683 IF( ln_subbas ) THEN 684 z_1(:,1) = 1._wp 685 WHERE ( gphit(jpi/2,:) < -30._wp ) z_1(:,1) = 0._wp 686 DO jk = 2, jpk 687 z_1(:,jk) = z_1(:,1) 688 END DO 689 ! ! Atlantic (jn=2) 690 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2) , 1._wp), 1, 1., ndex_atl , ndim_atl ) ! Lat-Depth 691 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)*z_1(:,:), 1._wp), 1, 1., ndex_atl_30 , ndim_atl_30 ) ! Lat-Depth 692 CALL wheneq ( jpj , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat 693 ! ! Pacific (jn=3) 694 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3) , 1._wp), 1, 1., ndex_pac , ndim_pac ) ! Lat-Depth 695 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)*z_1(:,:), 1._wp), 1, 1., ndex_pac_30 , ndim_pac_30 ) ! Lat-Depth 696 CALL wheneq ( jpj , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat 697 ! ! Indian (jn=4) 698 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4) , 1._wp), 1, 1., ndex_ind , ndim_ind ) ! Lat-Depth 699 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)*z_1(:,:), 1._wp), 1, 1., ndex_ind_30 , ndim_ind_30 ) ! Lat-Depth 700 CALL wheneq ( jpj , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat 701 ! ! Indo-Pacific (jn=5) 702 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5) , 1._wp), 1, 1., ndex_ipc , ndim_ipc ) ! Lat-Depth 703 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)*z_1(:,:), 1._wp), 1, 1., ndex_ipc_30 , ndim_ipc_30 ) ! Lat-Depth 704 CALL wheneq ( jpj , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat 705 ENDIF 706 ! 707 #if defined key_diaeiv 708 cl_comment = ' (Bolus part included)' 709 #else 710 cl_comment = ' ' 711 #endif 712 IF( ln_diaznl ) THEN ! Zonal mean T and S 713 CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , & 714 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 715 CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU" , & 716 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 717 718 CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , & 719 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 720 ! 721 IF (ln_subbas) THEN 722 CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , & 723 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 724 CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU" , & 725 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 726 CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2" , & 727 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 728 729 CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C" , & 730 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 731 CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU" , & 732 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 733 CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2" , & 734 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 735 736 CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C" , & 737 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 738 CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU" , & 739 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 740 CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2" , & 741 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 742 743 CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" , & 744 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 745 CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU" , & 746 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 747 CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2" , & 748 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 749 ENDIF 750 ENDIF 751 ! 752 ! Meridional Stream-Function (Eulerian and Bolus) 753 CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , & 754 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 755 IF( ln_subbas .AND. ln_diaznl ) THEN 756 CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" , & 757 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 758 CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv" , & 759 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 760 CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv" , & 761 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 762 CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,& 763 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 764 ENDIF 765 ! 766 ! Heat transport 767 CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , & 768 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 769 CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport" , & 770 "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 771 IF ( ln_ptrcomp ) THEN 772 CALL histdef( numptr, "sophtove", "Overturning Heat Transport" , & 773 "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 774 END IF 775 IF( ln_subbas ) THEN 776 CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment), & 777 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 778 CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) , & 779 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 780 CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment) , & 781 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 782 CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), & 783 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 784 ENDIF 785 ! 786 ! Salt transport 787 CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , & 788 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 789 CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport" , & 790 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 791 IF ( ln_ptrcomp ) THEN 792 CALL histdef( numptr, "sopstove", "Overturning Salt Transport" , & 793 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 794 END IF 795 #if defined key_diaeiv 796 ! Eddy induced velocity 797 CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global", & 798 "Sv" , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 799 CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport", & 800 "PW" , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 801 CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport", & 802 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 803 #endif 804 IF( ln_subbas ) THEN 805 CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment) , & 806 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 807 CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment) , & 808 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 809 CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment) , & 810 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 811 CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment), & 812 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 813 ENDIF 814 ! 815 CALL histend( numptr ) 816 ! 817 END IF 818 #if defined key_mpp_mpi 819 END IF 820 #endif 821 822 #if defined key_mpp_mpi 823 IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN 824 #else 825 IF( MOD( itmod, nn_fptr ) == 0 ) THEN 826 #endif 827 niter = niter + 1 828 829 IF( ln_diaznl ) THEN 830 CALL histwrite( numptr, "zosrfglo", niter, sjk (:,:,1) , ndim, ndex ) 831 CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1) , ndim, ndex ) 832 CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1) , ndim, ndex ) 833 834 IF (ln_subbas) THEN 835 CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl ) 836 CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac ) 837 CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind ) 838 CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc ) 839 840 CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2) , ndim_atl, ndex_atl ) 841 CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2) , ndim_atl, ndex_atl ) 842 CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3) , ndim_pac, ndex_pac ) 843 CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3) , ndim_pac, ndex_pac ) 844 CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4) , ndim_ind, ndex_ind ) 845 CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4) , ndim_ind, ndex_ind ) 846 CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5) , ndim_ipc, ndex_ipc ) 847 CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5) , ndim_ipc, ndex_ipc ) 848 END IF 849 ENDIF 850 851 ! overturning outputs: 852 CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex ) 853 IF( ln_subbas .AND. ln_diaznl ) THEN 854 CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 ) 855 CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 ) 856 CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 ) 857 CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 ) 858 ENDIF 859 #if defined key_diaeiv 860 CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim , ndex ) 861 #endif 862 863 ! heat transport outputs: 864 IF( ln_subbas ) THEN 865 CALL histwrite( numptr, "sohtatl", niter, htr(:,2) , ndim_h_atl_30, ndex_h_atl_30 ) 866 CALL histwrite( numptr, "sohtpac", niter, htr(:,3) , ndim_h_pac_30, ndex_h_pac_30 ) 867 CALL histwrite( numptr, "sohtind", niter, htr(:,4) , ndim_h_ind_30, ndex_h_ind_30 ) 868 CALL histwrite( numptr, "sohtipc", niter, htr(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 ) 869 CALL histwrite( numptr, "sostatl", niter, str(:,2) , ndim_h_atl_30, ndex_h_atl_30 ) 870 CALL histwrite( numptr, "sostpac", niter, str(:,3) , ndim_h_pac_30, ndex_h_pac_30 ) 871 CALL histwrite( numptr, "sostind", niter, str(:,4) , ndim_h_ind_30, ndex_h_ind_30 ) 872 CALL histwrite( numptr, "sostipc", niter, str(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 ) 873 ENDIF 874 875 CALL histwrite( numptr, "sophtadv", niter, htr_adv , ndim_h, ndex_h ) 876 CALL histwrite( numptr, "sophtldf", niter, htr_ldf , ndim_h, ndex_h ) 877 CALL histwrite( numptr, "sopstadv", niter, str_adv , ndim_h, ndex_h ) 878 CALL histwrite( numptr, "sopstldf", niter, str_ldf , ndim_h, ndex_h ) 879 IF( ln_ptrcomp ) THEN 880 CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h ) 881 CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h ) 882 ENDIF 883 #if defined key_diaeiv 884 CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1) , ndim_h, ndex_h ) 885 CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1) , ndim_h, ndex_h ) 886 #endif 887 ! 888 ENDIF 889 ! 890 CALL wrk_dealloc( jpj , zphi , zfoo ) 891 CALL wrk_dealloc( jpj , jpk, z_1 ) 892 ! 893 END SUBROUTINE dia_ptr_wri 435 ! 436 END FUNCTION ptr_sjk 437 894 438 895 439 !!====================================================================== -
branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r5034 r5600 46 46 USE iom 47 47 USE ioipsl 48 USE dynspg_oce, ONLY: un_adv, vn_adv ! barotropic velocities 49 48 50 #if defined key_lim2 49 51 USE limwri_2 … … 78 80 !!---------------------------------------------------------------------- 79 81 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 80 !! $Id 82 !! $Id$ 81 83 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 82 84 !!---------------------------------------------------------------------- … … 125 127 !! 126 128 INTEGER :: ji, jj, jk ! dummy loop indices 129 INTEGER :: jkbot ! 127 130 REAL(wp) :: zztmp, zztmpx, zztmpy ! 128 131 !! … … 142 145 ENDIF 143 146 144 IF( lk_vvl ) THEN 145 z3d(:,:,:) = tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) 146 CALL iom_put( "toce" , z3d ) ! heat content 147 IF( .NOT.lk_vvl ) THEN 148 CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 149 CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 150 CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 151 CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 152 ENDIF 153 154 CALL iom_put( "ssh" , sshn ) ! sea surface height 155 if( iom_use('ssh2') ) CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) ) ! square of sea surface height 156 157 CALL iom_put( "toce", tsn(:,:,:,jp_tem) ) ! 3D temperature 158 CALL iom_put( "sst", tsn(:,:,1,jp_tem) ) ! surface temperature 159 IF ( iom_use("sbt") ) THEN 147 160 DO jj = 1, jpj 148 161 DO ji = 1, jpi 149 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * fse3t_n(ji,jj,mikt(ji,jj)) 150 END DO 151 END DO 152 CALL iom_put( "sst" , z2d(:,:) ) ! sea surface heat content 162 jkbot = mbkt(ji,jj) 163 z2d(ji,jj) = tsn(ji,jj,jkbot,jp_tem) 164 END DO 165 END DO 166 CALL iom_put( "sbt", z2d ) ! bottom temperature 167 ENDIF 168 169 CALL iom_put( "soce", tsn(:,:,:,jp_sal) ) ! 3D salinity 170 CALL iom_put( "sss", tsn(:,:,1,jp_sal) ) ! surface salinity 171 IF ( iom_use("sbs") ) THEN 153 172 DO jj = 1, jpj 154 173 DO ji = 1, jpi 155 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem)**2 * fse3t_n(ji,jj,mikt(ji,jj)) 156 END DO 157 END DO 158 CALL iom_put( "sst2" , z2d(:,:) ) ! sea surface content of squared temperature 159 z3d(:,:,:) = tsn(:,:,:,jp_sal) * fse3t_n(:,:,:) 160 CALL iom_put( "soce" , z3d ) ! salinity content 174 jkbot = mbkt(ji,jj) 175 z2d(ji,jj) = tsn(ji,jj,jkbot,jp_sal) 176 END DO 177 END DO 178 CALL iom_put( "sbs", z2d ) ! bottom salinity 179 ENDIF 180 181 IF ( iom_use("taubot") ) THEN ! bottom stress 182 z2d(:,:) = 0._wp 183 DO jj = 2, jpjm1 184 DO ji = fs_2, fs_jpim1 ! vector opt. 185 zztmpx = ( bfrua(ji ,jj) * un(ji ,jj,mbku(ji ,jj)) & 186 & + bfrua(ji-1,jj) * un(ji-1,jj,mbku(ji-1,jj)) ) 187 zztmpy = ( bfrva(ji, jj) * vn(ji,jj ,mbkv(ji,jj )) & 188 & + bfrva(ji,jj-1) * vn(ji,jj-1,mbkv(ji,jj-1)) ) 189 z2d(ji,jj) = rau0 * SQRT( zztmpx * zztmpx + zztmpy * zztmpy ) * tmask(ji,jj,1) 190 ! 191 ENDDO 192 ENDDO 193 CALL lbc_lnk( z2d, 'T', 1. ) 194 CALL iom_put( "taubot", z2d ) 195 ENDIF 196 197 CALL iom_put( "uoce", un(:,:,:) ) ! 3D i-current 198 CALL iom_put( "ssu", un(:,:,1) ) ! surface i-current 199 IF ( iom_use("sbu") ) THEN 161 200 DO jj = 1, jpj 162 201 DO ji = 1, jpi 163 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * fse3t_n(ji,jj,mikt(ji,jj)) 164 END DO 165 END DO 166 CALL iom_put( "sss" , z2d(:,:) ) ! sea surface salinity content 202 jkbot = mbku(ji,jj) 203 z2d(ji,jj) = un(ji,jj,jkbot) 204 END DO 205 END DO 206 CALL iom_put( "sbu", z2d ) ! bottom i-current 207 ENDIF 208 #if defined key_dynspg_ts 209 CALL iom_put( "ubar", un_adv(:,:) ) ! barotropic i-current 210 #else 211 CALL iom_put( "ubar", un_b(:,:) ) ! barotropic i-current 212 #endif 213 214 CALL iom_put( "voce", vn(:,:,:) ) ! 3D j-current 215 CALL iom_put( "ssv", vn(:,:,1) ) ! surface j-current 216 IF ( iom_use("sbv") ) THEN 167 217 DO jj = 1, jpj 168 218 DO ji = 1, jpi 169 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal)**2 * fse3t_n(ji,jj,mikt(ji,jj)) 170 END DO 171 END DO 172 CALL iom_put( "sss2" , z2d(:,:) ) ! sea surface content of squared salinity 173 ELSE 174 CALL iom_put( "toce" , tsn(:,:,:,jp_tem) ) ! temperature 175 IF ( iom_use("sst") ) THEN 176 DO jj = 1, jpj 177 DO ji = 1, jpi 178 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) 179 END DO 180 END DO 181 CALL iom_put( "sst" , z2d(:,:) ) ! sea surface temperature 182 ENDIF 183 IF ( iom_use("sst2") ) CALL iom_put( "sst2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface temperature 184 CALL iom_put( "soce" , tsn(:,:,:,jp_sal) ) ! salinity 185 IF ( iom_use("sss") ) THEN 186 DO jj = 1, jpj 187 DO ji = 1, jpi 188 z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) 189 END DO 190 END DO 191 CALL iom_put( "sss" , z2d(:,:) ) ! sea surface salinity 192 ENDIF 193 CALL iom_put( "sss2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface salinity 194 END IF 195 IF( lk_vvl .AND. (.NOT. ln_dynadv_vec) ) THEN 196 CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) * fse3u_n(:,:,:) ) ! i-transport 197 CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:) * fse3v_n(:,:,:) ) ! j-transport 198 ELSE 199 CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) ) ! i-current 200 CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:) ) ! j-current 201 IF ( iom_use("ssu") ) THEN 202 DO jj = 1, jpj 203 DO ji = 1, jpi 204 z2d(ji,jj) = un(ji,jj,miku(ji,jj)) 205 END DO 206 END DO 207 CALL iom_put( "ssu" , z2d ) ! i-current 208 ENDIF 209 IF ( iom_use("ssv") ) THEN 210 DO jj = 1, jpj 211 DO ji = 1, jpi 212 z2d(ji,jj) = vn(ji,jj,mikv(ji,jj)) 213 END DO 214 END DO 215 CALL iom_put( "ssv" , z2d ) ! j-current 216 ENDIF 217 ENDIF 218 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. 219 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 220 IF( lk_zdfddm ) THEN 221 CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. 222 ENDIF 223 224 IF ( iom_use("sstgrad2") .OR. iom_use("sstgrad2") ) THEN 219 jkbot = mbkv(ji,jj) 220 z2d(ji,jj) = vn(ji,jj,jkbot) 221 END DO 222 END DO 223 CALL iom_put( "sbv", z2d ) ! bottom j-current 224 ENDIF 225 #if defined key_dynspg_ts 226 CALL iom_put( "vbar", vn_adv(:,:) ) ! barotropic j-current 227 #else 228 CALL iom_put( "vbar", vn_b(:,:) ) ! barotropic j-current 229 #endif 230 231 CALL iom_put( "woce", wn ) ! vertical velocity 232 IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN ! vertical mass transport & its square value 233 ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 234 z2d(:,:) = rau0 * e12t(:,:) 235 DO jk = 1, jpk 236 z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 237 END DO 238 CALL iom_put( "w_masstr" , z3d ) 239 IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 240 ENDIF 241 242 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. 243 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 244 CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. (useful only with key_zdfddm) 245 246 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 225 247 DO jj = 2, jpjm1 ! sst gradient 226 248 DO ji = fs_2, fs_jpim1 ! vector opt. … … 234 256 CALL lbc_lnk( z2d, 'T', 1. ) 235 257 CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient 236 !CDIR NOVERRCHK<237 258 z2d(:,:) = SQRT( z2d(:,:) ) 238 259 CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient … … 243 264 z2d(:,:) = 0._wp 244 265 DO jk = 1, jpkm1 245 DO jj = 2, jpjm1246 DO ji = fs_2, fs_jpim1 ! vector opt.266 DO jj = 1, jpj 267 DO ji = 1, jpi 247 268 z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 248 269 END DO 249 270 END DO 250 271 END DO 251 CALL lbc_lnk( z2d, 'T', 1. )252 272 CALL iom_put( "heatc", (rau0 * rcp) * z2d ) ! vertically integrated heat content (J/m2) 253 273 ENDIF … … 256 276 z2d(:,:) = 0._wp 257 277 DO jk = 1, jpkm1 258 DO jj = 2, jpjm1259 DO ji = fs_2, fs_jpim1 ! vector opt.278 DO jj = 1, jpj 279 DO ji = 1, jpi 260 280 z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 261 281 END DO 262 282 END DO 263 283 END DO 264 CALL lbc_lnk( z2d, 'T', 1. )265 284 CALL iom_put( "saltc", rau0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) 266 285 ENDIF … … 419 438 zdt = rdt 420 439 IF( nacc == 1 ) zdt = rdtmin 421 IF( ln_mskland ) THEN ; clop = "only(x)" ! put 1.e+20 on land (very expensive!!) 422 ELSE ; clop = "x" ! no use of the mask value (require less cpu time) 423 ENDIF 440 clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes) 424 441 #if defined key_diainstant 425 442 zsto = nwrite * zdt … … 621 638 ENDIF 622 639 623 IF( .NOT. l k_cpl ) THEN640 IF( .NOT. ln_cpl ) THEN 624 641 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 625 642 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 630 647 ENDIF 631 648 632 IF( l k_cpl .AND. nn_ice <= 1 ) THEN649 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 633 650 CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp 634 651 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 653 670 #endif 654 671 655 IF( l k_cpl .AND. nn_ice == 2 ) THEN672 IF( ln_cpl .AND. nn_ice == 2 ) THEN 656 673 CALL histdef( nid_T,"soicetem" , "Ice Surface Temperature" , "K" , & ! tn_ice 657 674 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 808 825 ENDIF 809 826 810 IF( .NOT. l k_cpl ) THEN827 IF( .NOT. ln_cpl ) THEN 811 828 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 812 829 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping … … 814 831 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 815 832 ENDIF 816 IF( l k_cpl .AND. nn_ice <= 1 ) THEN833 IF( ln_cpl .AND. nn_ice <= 1 ) THEN 817 834 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 818 835 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping … … 830 847 #endif 831 848 832 IF( l k_cpl .AND. nn_ice == 2 ) THEN849 IF( ln_cpl .AND. nn_ice == 2 ) THEN 833 850 CALL histwrite( nid_T, "soicetem", it, tn_ice(:,:,1) , ndim_hT, ndex_hT ) ! surf. ice temperature 834 851 CALL histwrite( nid_T, "soicealb", it, alb_ice(:,:,1), ndim_hT, ndex_hT ) ! ice albedo
Note: See TracChangeset
for help on using the changeset viewer.
