Changeset 2715 for trunk/NEMOGCM/NEMO/OPA_SRC/DIA
- Timestamp:
- 2011-03-30T17:58:35+02:00 (13 years ago)
- Location:
- trunk/NEMOGCM/NEMO/OPA_SRC/DIA
- Files:
-
- 6 edited
-
diaar5.F90 (modified) (8 diffs)
-
diadimg.F90 (modified) (4 diffs)
-
diahth.F90 (modified) (4 diffs)
-
diaptr.F90 (modified) (26 diffs)
-
diawri.F90 (modified) (13 diffs)
-
diawri_dimg.h90 (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r2528 r2715 7 7 !! 3.3 ! 2010-10 (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA 8 8 !!---------------------------------------------------------------------- 9 #if defined key_diaar5 9 #if defined key_diaar5 || defined key_esopa 10 10 !!---------------------------------------------------------------------- 11 11 !! 'key_diaar5' : activate ar5 diagnotics … … 25 25 PUBLIC dia_ar5 ! routine called in step.F90 module 26 26 PUBLIC dia_ar5_init ! routine called in opa.F90 module 27 PUBLIC dia_ar5_alloc ! routine called in nemogcm.F90 module 27 28 28 29 LOGICAL, PUBLIC, PARAMETER :: lk_diaar5 = .TRUE. ! coupled flag … … 30 31 REAL(wp) :: vol0 ! ocean volume (interior domain) 31 32 REAL(wp) :: area_tot ! total ocean surface (interior domain) 32 REAL(wp), DIMENSION(jpi,jpj) :: area ! cell surface (interior domain)33 REAL(wp), DIMENSION(jpi,jpj) :: thick0 ! ocean thickness (interior domain)34 REAL(wp), DIMENSION(jpi,jpj,jpk) :: sn0 ! initial salinity33 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: area ! cell surface (interior domain) 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,: ) :: thick0 ! ocean thickness (interior domain) 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sn0 ! initial salinity 35 36 36 37 !! * Substitutions … … 43 44 CONTAINS 44 45 46 FUNCTION dia_ar5_alloc() 47 !!---------------------------------------------------------------------- 48 !! *** ROUTINE dia_ar5_alloc *** 49 !!---------------------------------------------------------------------- 50 INTEGER :: dia_ar5_alloc 51 !!---------------------------------------------------------------------- 52 ! 53 ALLOCATE( area(jpi,jpj), thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 54 ! 55 IF( lk_mpp ) CALL mpp_sum ( dia_ar5_alloc ) 56 IF( dia_ar5_alloc /= 0 ) CALL ctl_warn('dia_ar5_alloc: failed to allocate arrays') 57 ! 58 END FUNCTION dia_ar5_alloc 59 60 45 61 SUBROUTINE dia_ar5( kt ) 46 62 !!---------------------------------------------------------------------- … … 48 64 !! 49 65 !! ** Purpose : compute and output some AR5 diagnostics 50 !! 51 !!---------------------------------------------------------------------- 66 !!---------------------------------------------------------------------- 67 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 68 USE wrk_nemo, ONLY: zarea_ssh => wrk_2d_1 , zbotpres => wrk_2d_2 ! 2D workspace 69 USE wrk_nemo, ONLY: zrhd => wrk_3d_1 , zrhop => wrk_3d_2 ! 3D - 70 USE wrk_nemo, ONLY: ztsn => wrk_4d_1 ! 4D - 71 ! 52 72 INTEGER, INTENT( in ) :: kt ! ocean time-step index 53 ! !73 ! 54 74 INTEGER :: ji, jj, jk ! dummy loop arguments 55 75 REAL(wp) :: zvolssh, zvol, zssh_steric, zztmp, zarho, ztemp, zsal, zmass 56 REAL(wp), DIMENSION(jpi,jpj ) :: zarea_ssh, zbotpres57 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrhd, zrhop58 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: ztsn59 76 !!-------------------------------------------------------------------- 77 78 IF( wrk_in_use(2, 1,2) .OR. & 79 wrk_in_use(3, 1,2) .OR. & 80 wrk_in_use(4, 1) ) THEN 81 CALL ctl_stop('dia_ar5: requested workspace arrays unavailable') ; RETURN 82 ENDIF 60 83 61 84 CALL iom_put( 'cellthc', fse3t(:,:,:) ) … … 137 160 CALL iom_put( 'saltot' , zsal ) 138 161 ! 162 IF( wrk_not_released(2, 1,2) .OR. & 163 wrk_not_released(3, 1,2) .OR. & 164 wrk_not_released(4, 1) ) CALL ctl_stop('dia_ar5: failed to release workspace arrays') 165 ! 139 166 END SUBROUTINE dia_ar5 140 167 … … 146 173 !! ** Purpose : initialization for AR5 diagnostic computation 147 174 !!---------------------------------------------------------------------- 175 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 176 USE wrk_nemo, ONLY: wrk_4d_1 ! 4D workspace 177 ! 148 178 INTEGER :: inum 149 179 INTEGER :: ik 150 180 INTEGER :: ji, jj, jk ! dummy loop indices 151 181 REAL(wp) :: zztmp 152 REAL(wp), DIMENSION(jpi,jpj,jpk, 2) :: zsaldta ! Jan/Dec levitus salinity 153 !!---------------------------------------------------------------------- 154 ! 182 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 183 !!---------------------------------------------------------------------- 184 ! 185 IF(wrk_in_use(4, 1) ) THEN 186 CALL ctl_stop('dia_ar5_init: requested workspace array unavailable.') ; RETURN 187 ENDIF 188 zsaldta => wrk_4d_1(:,:,:,1:2) 189 190 ! ! allocate dia_ar5 arrays 191 IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 192 155 193 area(:,:) = e1t(:,:) * e2t(:,:) * tmask_i(:,:) 156 194 … … 183 221 ENDIF 184 222 ! 223 IF( wrk_not_released(4, 1) ) CALL ctl_stop('dia_ar5_init: failed to release workspace array') 224 ! 185 225 END SUBROUTINE dia_ar5_init 186 226 -
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90
r2528 r2715 6 6 # if defined key_dimgout 7 7 !!---------------------------------------------------------------------- 8 !! * Modules used9 8 USE oce ! ocean dynamics and tracers 10 9 USE dom_oce ! ocean space and time domain … … 15 14 PRIVATE 16 15 17 !! * Accessibility18 16 PUBLIC dia_wri_dimg ! called by trd_mld (eg) 17 PUBLIC dia_wri_dimg_alloc ! called by nemo_alloc in nemogcm.F90 18 19 20 !! These workspace arrays are inside the module so that we can make them 21 !! allocatable in a clean way. Not done in wrk_nemo because these are of KIND(sp). 22 REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: z42d ! 2d temporary workspace (sp) 23 REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:) :: z4dep ! vertical level (sp) 19 24 20 25 !! * Substitutions 21 26 # include "domzgr_substitute.h90" 22 23 27 !!---------------------------------------------------------------------- 24 28 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 26 30 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 27 31 !!---------------------------------------------------------------------- 28 29 32 CONTAINS 30 33 31 SUBROUTINE dia_wri_dimg(cd_name, cd_text, ptab, klev, cd_type , ksubi ) 34 FUNCTION dia_wri_dimg_alloc() 35 !!--------------------------------------------------------------------- 36 !! *** ROUTINE dia_wri_dimg_alloc *** 37 !! 38 !!--------------------------------------------------------------------- 39 INTEGER :: dia_wri_dimg_alloc ! return value 40 !!--------------------------------------------------------------------- 41 ! 42 ALLOCATE( z42d(jpi,jpj), z4dep(jpk), STAT=dia_wri_dimg_alloc ) 43 ! 44 IF( lk_mpp ) CALL mpp_sum ( dia_wri_dimg_alloc ) 45 IF( dia_wri_dimg_alloc /= 0 ) CALL ctl_warn('dia_wri_dimg_alloc: allocation of array failed.') 46 ! 47 END FUNCTION dia_wri_dimg_alloc 48 49 50 SUBROUTINE dia_wri_dimg( cd_name, cd_text, ptab, klev, cd_type , ksubi ) 32 51 !!------------------------------------------------------------------------- 33 52 !! *** ROUTINE dia_wri_dimg *** 34 53 !! 35 !! ** Purpose : write ptab in the dimg file cd_name, with comment cd_text.36 !! ptab has klev x 2D fields54 !! ** Purpose : write ptab in the dimg file cd_name, with comment cd_text. 55 !! ptab has klev x 2D fields 37 56 !! 38 !! ** Action : 39 !! Define header variables from the config parameters 40 !! Open the dimg file on unit inum = 14 ( IEEE I4R4 file ) 41 !! Write header on record 1 42 !! Write ptab on the following klev records 57 !! ** Action : Define header variables from the config parameters 58 !! Open the dimg file on unit inum = 14 ( IEEE I4R4 file ) 59 !! Write header on record 1 60 !! Write ptab on the following klev records 43 61 !! 44 !! History : 45 !! 03-12 (J.M. Molines ) : Original. Replace ctl_opn, writn2d 62 !! History : 2003-12 (J.M. Molines ) : Original. Replace ctl_opn, writn2d 46 63 !!--------------------------------------------------------------------------- 47 !! * Arguments48 64 CHARACTER(len=*),INTENT(in) :: & 49 65 & cd_name, & ! dimg file name … … 63 79 REAL(sp) :: zdx,zdy,zspval,zwest,ztimm 64 80 REAL(sp) :: zsouth 65 REAL(sp),DIMENSION(jpi,jpj) :: z42d ! 2d temporary workspace (sp)66 REAL(sp),DIMENSION(jpk) :: z4dep ! vertical level (sp)67 81 68 82 CHARACTER(LEN=80) :: clname ! name of file in case of dimgnnn 69 83 CHARACTER(LEN=4) :: clver='@!01' ! dimg string identifier 70 84 !!--------------------------------------------------------------------------- 85 86 ! ! allocate dia_wri_dimg array 87 IF( dia_wri_dimg_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_wri_dimg : unable to allocate arrays' ) 71 88 72 89 !! * Initialisations -
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90
r2561 r2715 21 21 USE phycst ! physical constants 22 22 USE in_out_manager ! I/O manager 23 USE lib_mpp ! MPP library 23 24 USE iom ! I/O library 24 25 … … 26 27 PRIVATE 27 28 28 PUBLIC dia_hth ! routine called by step.F90 29 30 LOGICAL , PUBLIC, PARAMETER :: lk_diahth = .TRUE. !: thermocline-20d depths flag 29 PUBLIC dia_hth ! routine called by step.F90 30 PUBLIC dia_hth_alloc ! routine called by nemogcm.F90 31 32 LOGICAL , PUBLIC, PARAMETER :: lk_diahth = .TRUE. !: thermocline-20d depths flag 31 33 ! note: following variables should move to local variables once iom_put is always used 32 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: hth!: depth of the max vertical temperature gradient [m]33 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: hd20!: depth of 20 C isotherm [m]34 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: hd28!: depth of 28 C isotherm [m]35 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: htc3!: heat content of first 300 m [W]34 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hth !: depth of the max vertical temperature gradient [m] 35 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd20 !: depth of 20 C isotherm [m] 36 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hd28 !: depth of 28 C isotherm [m] 37 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: htc3 !: heat content of first 300 m [W] 36 38 37 39 !! * Substitutions 38 40 # include "domzgr_substitute.h90" 39 41 !!---------------------------------------------------------------------- 40 !! NEMO/OPA 3.3 , NEMO Consortium (2010)42 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 41 43 !! $Id$ 42 44 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 43 45 !!---------------------------------------------------------------------- 44 46 CONTAINS 47 48 FUNCTION dia_hth_alloc() 49 !!--------------------------------------------------------------------- 50 INTEGER :: dia_hth_alloc 51 !!--------------------------------------------------------------------- 52 ! 53 ALLOCATE(hth(jpi,jpj), hd20(jpi,jpj), hd28(jpi,jpj), htc3(jpi,jpj), STAT=dia_hth_alloc) 54 ! 55 IF( lk_mpp ) CALL mpp_sum ( dia_hth_alloc ) 56 IF(dia_hth_alloc /= 0) CALL ctl_warn('dia_hth_alloc: failed to allocate arrays.') 57 ! 58 END FUNCTION dia_hth_alloc 59 45 60 46 61 SUBROUTINE dia_hth( kt ) … … 68 83 INTEGER :: ji, jj, jk ! dummy loop arguments 69 84 INTEGER :: iid, ilevel ! temporary integers 70 INTEGER, DIMENSION(jpi,jpj) :: ik20, ik28! levels85 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ik20, ik28 ! levels 71 86 REAL(wp) :: zavt5 = 5.e-4_wp ! Kz criterion for the turbocline depth 72 87 REAL(wp) :: zrho3 = 0.03_wp ! density criterion for mixed layer depth … … 76 91 REAL(wp) :: zztmp, zzdep ! temporary scalars inside do loop 77 92 REAL(wp) :: zu, zv, zw, zut, zvt ! temporary workspace 78 REAL(wp), DIMENSION(jpi,jpj) :: zabs2! MLD: abs( tn - tn(10m) ) = ztem279 REAL(wp), DIMENSION(jpi,jpj) :: ztm2! Top of thermocline: tn = tn(10m) - ztem280 REAL(wp), DIMENSION(jpi,jpj) :: zrho10_3! MLD: rho = rho10m + zrho381 REAL(wp), DIMENSION(jpi,jpj) :: zpycn! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC)82 REAL(wp), DIMENSION(jpi,jpj) :: ztinv! max of temperature inversion83 REAL(wp), DIMENSION(jpi,jpj) :: zdepinv! depth of temperature inversion84 REAL(wp), DIMENSION(jpi,jpj) :: zrho0_3! MLD rho = rho(surf) = 0.0385 REAL(wp), DIMENSION(jpi,jpj) :: zrho0_1! MLD rho = rho(surf) = 0.0186 REAL(wp), DIMENSION(jpi,jpj) :: zmaxdzT! max of dT/dz87 REAL(wp), DIMENSION(jpi,jpj) :: zthick! vertical integration thickness88 REAL(wp), DIMENSION(jpi,jpj) :: zdelr! delta rho equivalent to deltaT = 0.293 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zabs2 ! MLD: abs( tn - tn(10m) ) = ztem2 94 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ztm2 ! Top of thermocline: tn = tn(10m) - ztem2 95 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zrho10_3 ! MLD: rho = rho10m + zrho3 96 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zpycn ! pycnocline: rho = rho10m + (dr/dT)(T,S,10m)*(-0.2 degC) 97 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ztinv ! max of temperature inversion 98 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdepinv ! depth of temperature inversion 99 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zrho0_3 ! MLD rho = rho(surf) = 0.03 100 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zrho0_1 ! MLD rho = rho(surf) = 0.01 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zmaxdzT ! max of dT/dz 102 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zthick ! vertical integration thickness 103 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zdelr ! delta rho equivalent to deltaT = 0.2 89 104 !!---------------------------------------------------------------------- 90 105 91 106 IF( kt == nit000 ) THEN 107 ! ! allocate dia_hth array 108 IF( dia_hth_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate standard arrays' ) 109 110 IF(.not. ALLOCATED(ik20))THEN 111 ALLOCATE(ik20(jpi,jpj), ik28(jpi,jpj), & 112 & zabs2(jpi,jpj), & 113 & ztm2(jpi,jpj), & 114 & zrho10_3(jpi,jpj),& 115 & zpycn(jpi,jpj), & 116 & ztinv(jpi,jpj), & 117 & zdepinv(jpi,jpj), & 118 & zrho0_3(jpi,jpj), & 119 & zrho0_1(jpi,jpj), & 120 & zmaxdzT(jpi,jpj), & 121 & zthick(jpi,jpj), & 122 & zdelr(jpi,jpj), STAT=ji) 123 IF( lk_mpp ) CALL mpp_sum(ji) 124 IF( ji /= 0 ) CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard ocean arrays' ) 125 END IF 126 92 127 IF(lwp) WRITE(numout,*) 93 128 IF(lwp) WRITE(numout,*) 'dia_hth : diagnostics of the thermocline depth' -
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r2571 r2715 50 50 INTEGER , PUBLIC :: nn_fwri = 15 !: frequency of ptr outputs [time step] 51 51 52 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE:: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.)53 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE:: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.)52 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.) 53 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.) 54 54 55 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: btmsk ! T-point basin interior masks 56 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 57 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr , str ! adv heat and salt transports (approx) 58 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 59 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 60 #if defined key_diaeiv 61 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 62 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 63 #endif 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 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr , str ! adv heat and salt transports (approx) 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 62 64 63 65 64 INTEGER :: niter ! … … 71 70 REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp) 72 71 REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg 72 73 REAL(wp), TARGET, DIMENSION(:), ALLOCATABLE, SAVE :: p_fval1d 74 REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d 75 76 !! Integer, 1D workspace arrays. Not common enough to be implemented in 77 !! wrk_nemo module. 78 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc 79 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 80 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 73 81 74 82 !! * Substitutions … … 82 90 CONTAINS 83 91 92 FUNCTION dia_ptr_alloc() 93 !!---------------------------------------------------------------------- 94 !! *** ROUTINE dia_ptr_alloc *** 95 !!---------------------------------------------------------------------- 96 INTEGER :: dia_ptr_alloc ! return value 97 INTEGER, DIMENSION(5) :: ierr 98 !!---------------------------------------------------------------------- 99 ierr(:) = 0 100 ! 101 ALLOCATE( btmsk(jpi,jpj,nptr) , & 102 & htr_adv(jpj) , str_adv(jpj) , & 103 & htr_ldf(jpj) , str_ldf(jpj) , & 104 & htr_ove(jpj) , str_ove(jpj), & 105 & htr(jpj,nptr) , str(jpj,nptr) , & 106 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 107 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1) ) 108 ! 109 #if defined key_diaeiv 110 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 111 & v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 112 #endif 113 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3)) 114 ! 115 ALLOCATE(ndex(jpj*jpk), ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 116 & ndex_ind(jpj*jpk), ndex_ipc(jpj*jpk), & 117 & ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 118 119 ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk), & 120 & ndex_h(jpj), ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 121 & ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5) ) 122 ! 123 dia_ptr_alloc = MAXVAL( ierr ) 124 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) 125 ! 126 END FUNCTION dia_ptr_alloc 127 128 84 129 FUNCTION ptr_vj_3d( pva ) RESULT ( p_fval ) 85 130 !!---------------------------------------------------------------------- … … 97 142 INTEGER :: ji, jj, jk ! dummy loop arguments 98 143 INTEGER :: ijpj ! ??? 99 REAL(wp), DIMENSION(jpj) :: p_fval! function value144 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 100 145 !!-------------------------------------------------------------------- 101 146 ! 147 p_fval => p_fval1d 148 102 149 ijpj = jpj 103 150 p_fval(:) = 0._wp … … 109 156 END DO 110 157 END DO 111 ! 112 #if defined key_mpp_mpi 113 CALL mpp_sum( p_fval, ijpj, ncomm_znl) 158 #if defined key_mpp_mpi 159 IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl) 114 160 #endif 115 161 ! … … 128 174 !! ** Action : - p_fval: i-k-mean poleward flux of pva 129 175 !!---------------------------------------------------------------------- 176 IMPLICIT none 130 177 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 131 178 !! 132 INTEGER :: ji,jj ! dummy loop arguments133 INTEGER :: ijpj ! ???134 REAL(wp), DIMENSION(jpj) :: p_fval! function value179 INTEGER :: ji,jj ! dummy loop arguments 180 INTEGER :: ijpj ! ??? 181 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 135 182 !!-------------------------------------------------------------------- 136 183 ! 184 p_fval => p_fval1d 185 137 186 ijpj = jpj 138 187 p_fval(:) = 0._wp … … 142 191 END DO 143 192 END DO 144 !145 193 #if defined key_mpp_mpi 146 194 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) … … 161 209 !! ** Action : - p_fval: i-mean poleward flux of pva 162 210 !!---------------------------------------------------------------------- 211 #if defined key_mpp_mpi 212 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 213 USE wrk_nemo, ONLY: zwork => wrk_1d_1 214 #endif 215 !! 216 IMPLICIT none 163 217 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 164 218 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 165 219 !! 166 INTEGER :: ji, jj, jk! dummy loop arguments167 REAL(wp), DIMENSION(jpj,jpk) :: p_fval! return function value220 INTEGER :: ji, jj, jk ! dummy loop arguments 221 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 168 222 #if defined key_mpp_mpi 169 223 INTEGER, DIMENSION(1) :: ish 170 224 INTEGER, DIMENSION(2) :: ish2 171 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! 1D workspace225 INTEGER :: ijpjjpk 172 226 #endif 173 227 !!-------------------------------------------------------------------- 174 228 ! 229 #if defined key_mpp_mpi 230 IF( wrk_in_use(1, 1) ) THEN 231 CALL ctl_stop('ptr_vjk: ERROR - requested workspace array is unavailable') ; RETURN 232 END IF 233 #endif 234 235 p_fval => p_fval2d 236 175 237 p_fval(:,:) = 0._wp 176 238 ! … … 195 257 ! 196 258 #if defined key_mpp_mpi 197 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 198 zwork(:) = RESHAPE( p_fval, ish ) 199 CALL mpp_sum( zwork, jpj*jpk, ncomm_znl ) 259 ijpjjpk = jpj*jpk 260 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 261 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 262 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 200 263 p_fval(:,:) = RESHAPE( zwork, ish2 ) 201 264 #endif 202 265 ! 266 #if defined key_mpp_mpi 267 IF( wrk_not_released(1, 1) ) CALL ctl_stop('ptr_vjk: ERROR - failed to release workspace array') 268 #endif 269 ! 203 270 END FUNCTION ptr_vjk 204 271 … … 214 281 !! ** Action : - p_fval: i-sum of e1t*e3t*pta 215 282 !!---------------------------------------------------------------------- 283 #if defined key_mpp_mpi 284 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 285 USE wrk_nemo, ONLY: zwork => wrk_1d_1 286 #endif 287 !! 216 288 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point 217 289 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 218 290 !! 219 INTEGER ::ji, jj, jk ! dummy loop arguments220 REAL(wp), DIMENSION(jpj,jpk) ::p_fval ! return function value291 INTEGER :: ji, jj, jk ! dummy loop arguments 292 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 221 293 #if defined key_mpp_mpi 222 294 INTEGER, DIMENSION(1) :: ish 223 295 INTEGER, DIMENSION(2) :: ish2 224 REAL(wp),DIMENSION(jpj*jpk) :: zwork ! 1D workspace296 INTEGER :: ijpjjpk 225 297 #endif 226 298 !!-------------------------------------------------------------------- 227 299 ! 300 #if defined key_mpp_mpi 301 IF( wrk_in_use(1, 1) ) THEN 302 CALL ctl_stop('ptr_tjk: requested workspace array unavailable') ; RETURN 303 ENDIF 304 #endif 305 306 p_fval => p_fval2d 307 228 308 p_fval(:,:) = 0._wp 229 309 DO jk = 1, jpkm1 … … 235 315 END DO 236 316 #if defined key_mpp_mpi 317 ijpjjpk = jpj*jpk 237 318 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 238 zwork( :)= RESHAPE( p_fval, ish )239 CALL mpp_sum( zwork, jpj*jpk, ncomm_znl )319 zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 320 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 240 321 p_fval(:,:)= RESHAPE( zwork, ish2 ) 241 322 #endif 242 323 ! 324 #if defined key_mpp_mpi 325 IF( wrk_not_released(1, 1) ) CALL ctl_stop('ptr_tjk: failed to release workspace array') 326 #endif 327 ! 243 328 END FUNCTION ptr_tjk 244 329 … … 250 335 USE oce, vt => ua ! use ua as workspace 251 336 USE oce, vs => ua ! use ua as workspace 337 IMPLICIT none 252 338 !! 253 339 INTEGER, INTENT(in) :: kt ! ocean time step index … … 364 450 !!---------------------------------------------------------------------- 365 451 452 ! ! allocate dia_ptr arrays 453 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate arrays' ) 454 366 455 REWIND( numnam ) ! Read Namelist namptr : poleward transport parameters 367 456 READ ( numnam, namptr ) … … 388 477 IF( .NOT. ln_diaptr ) THEN ! diaptr not used 389 478 RETURN 390 ELSE ! Allocate the diaptr arrays391 ALLOCATE( btmsk(jpi,jpj,nptr) , &392 & htr_adv(jpj) , str_adv(jpj) , htr_ldf(jpj) , str_ldf(jpj) , htr_ove(jpj) , str_ove(jpj), &393 & htr(jpj,nptr) , str(jpj,nptr) , &394 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , &395 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr )396 !397 IF( ierr > 0 ) THEN398 CALL ctl_stop( 'dia_ptr_init : unable to allocate standard arrays' ) ; RETURN399 ENDIF400 #if defined key_diaeiv401 !! IF( lk_diaeiv ) & ! eddy induced velocity arrays402 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , v_msf_eiv(jpj,jpk,nptr) , STAT=ierr )403 !404 IF( ierr > 0 ) THEN405 CALL ctl_stop( 'dia_ptr_init : unable to allocate eiv arrays' ) ; RETURN406 ENDIF407 #endif408 479 ENDIF 409 480 410 IF( lk_mpp ) CALL mpp_ini_znl ! Define MPI communicator for zonal sum481 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 411 482 412 483 IF( ln_subbas ) THEN ! load sub-basin mask … … 460 531 !! ** Method : NetCDF file 461 532 !!---------------------------------------------------------------------- 533 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 534 USE wrk_nemo, ONLY: zphi => wrk_1d_1, zfoo => wrk_1d_2 ! 1D workspace 535 USE wrk_nemo, ONLY: z_1 => wrk_2d_1 ! 2D - 536 !! 462 537 INTEGER, INTENT(in) :: kt ! ocean time-step index 463 538 !! 464 539 INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw 465 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc 466 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30 467 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 468 INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc 469 INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 470 INTEGER, SAVE, DIMENSION (jpj) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 471 !! 472 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 473 INTEGER :: iline, it, itmod, ji, jj, jk ! 540 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc 541 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30 542 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 543 !! 544 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 545 INTEGER :: iline, it, itmod, ji, jj, jk ! 474 546 #if defined key_iomput 475 INTEGER :: inum ! temporary logical unit 476 #endif 477 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 478 REAL(wp), DIMENSION(jpj) :: zphi, zfoo 479 REAL(wp), DIMENSION(jpj,jpk) :: z_1 480 !!---------------------------------------------------------------------- 547 INTEGER :: inum ! temporary logical unit 548 #endif 549 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 550 !!---------------------------------------------------------------------- 551 552 IF( wrk_in_use(1, 1,2) .OR. wrk_in_use(2, 1) ) THEN 553 CALL ctl_stop('dia_ptr_wri: requested workspace arrays unavailable') ; RETURN 554 ENDIF 481 555 482 556 ! define time axis … … 507 581 IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole 508 582 IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole 509 zphi( :) = 0._wp583 zphi(1:jpj) = 0._wp 510 584 DO ji = mi0(iline), mi1(iline) 511 zphi( :) = gphiv(ji,:) ! if iline is in the local domain585 zphi(1:jpj) = gphiv(ji,:) ! if iline is in the local domain 512 586 ! Correct highest latitude for some configurations - will work if domain is parallelized in J ? 513 587 IF( jp_cfg == 05 ) THEN … … 533 607 ELSE ! OTHER configurations 534 608 ! ! ======================= 535 zphi( :) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line609 zphi(1:jpj) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line 536 610 ! 537 611 ENDIF … … 555 629 556 630 zout = nn_fwri * zdt 557 zfoo(:) = 0._wp 558 559 ! Compute julian date from starting date of the run 560 561 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) 562 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 631 zfoo(1:jpj) = 0._wp 632 633 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) ! Compute julian date from starting date of the run 634 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 563 635 564 636 #if defined key_iomput … … 583 655 CALL histvert( numptr, "depthw", "Vertical W levels", & 584 656 & "m", jpk, gdepw_0, ndepidzw, "down" ) 585 586 657 ! 587 658 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth … … 617 688 cl_comment = ' ' 618 689 #endif 619 ! Zonal mean T and S 620 621 IF( ln_diaznl ) THEN 690 IF( ln_diaznl ) THEN ! Zonal mean T and S 622 691 CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , & 623 692 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) … … 627 696 CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , & 628 697 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 629 698 ! 630 699 IF (ln_subbas) THEN 631 700 CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , & … … 657 726 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 658 727 ENDIF 659 660 728 ENDIF 661 729 ! 662 730 ! Meridional Stream-Function (Eulerian and Bolus) 663 664 731 CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , & 665 732 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) … … 674 741 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 675 742 ENDIF 676 743 ! 677 744 ! Heat transport 678 679 745 CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , & 680 746 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) … … 695 761 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 696 762 ENDIF 697 698 763 ! 699 764 ! Salt transport 700 701 765 CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , & 702 766 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) … … 726 790 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 727 791 ENDIF 728 792 ! 729 793 CALL histend( numptr ) 730 794 ! 731 795 END IF 732 796 #if defined key_mpp_mpi … … 802 866 ENDIF 803 867 ! 804 END SUBROUTINE dia_ptr_wri 868 IF( wrk_not_released(1, 1,2) .OR. & 869 wrk_not_released(2, 1) ) CALL ctl_stop('dia_ptr_wri: failed to release workspace arrays') 870 ! 871 END SUBROUTINE dia_ptr_wri 805 872 806 873 !!====================================================================== -
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r2561 r2715 48 48 USE dtatem 49 49 USE dtasal 50 USE lib_mpp ! MPP library 50 51 51 52 IMPLICIT NONE … … 54 55 PUBLIC dia_wri ! routines called by step.F90 55 56 PUBLIC dia_wri_state 57 PUBLIC dia_wri_alloc ! Called by nemogcm module 56 58 57 59 INTEGER :: nid_T, nz_T, nh_T, ndim_T, ndim_hT ! grid_T file … … 60 62 INTEGER :: nid_W, nz_W, nh_W ! grid_W file 61 63 INTEGER :: ndex(1) ! ??? 62 INTEGER, DIMENSION(jpi*jpj) ::ndex_hT, ndex_hU, ndex_hV63 INTEGER, DIMENSION(jpi*jpj*jpk) ::ndex_T, ndex_U, ndex_V64 INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV 65 INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V 64 66 65 67 !! * Substitutions … … 74 76 CONTAINS 75 77 78 INTEGER FUNCTION dia_wri_alloc() 79 !!---------------------------------------------------------------------- 80 INTEGER, DIMENSION(2) :: ierr 81 !!---------------------------------------------------------------------- 82 ! 83 ierr = 0 84 ! 85 ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , & 86 & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , & 87 & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) ) 88 ! 89 dia_wri_alloc = MAXVAL(ierr) 90 IF( lk_mpp ) CALL mpp_sum( dia_wri_alloc ) 91 ! 92 END FUNCTION dia_wri_alloc 93 76 94 #if defined key_dimgout 77 95 !!---------------------------------------------------------------------- … … 88 106 !! 'key_iomput' use IOM library 89 107 !!---------------------------------------------------------------------- 108 90 109 SUBROUTINE dia_wri( kt ) 91 110 !!--------------------------------------------------------------------- … … 98 117 !!---------------------------------------------------------------------- 99 118 USE oce, ONLY : z3d => ta ! use ta as 3D workspace 119 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 120 USE wrk_nemo, ONLY: z2d => wrk_2d_1 100 121 !! 101 122 INTEGER, INTENT( in ) :: kt ! ocean time-step index … … 103 124 INTEGER :: ji, jj, jk ! dummy loop indices 104 125 REAL(wp) :: zztmp, zztmpx, zztmpy ! 105 REAL(wp), DIMENSION(jpi,jpj) :: z2d !106 126 !!---------------------------------------------------------------------- 107 127 ! 128 IF( wrk_in_use(2, 1))THEN 129 CALL ctl_stop('dia_wri: ERROR - requested 2D workspace unavailable.') 130 RETURN 131 END IF 132 ! 108 133 ! Output the initial state and forcings 109 134 IF( ninist == 1 ) THEN … … 175 200 ENDIF 176 201 ! 202 IF( wrk_not_released(2, 1))THEN 203 CALL ctl_stop('dia_wri: ERROR - failed to release 2D workspace.') 204 RETURN 205 END IF 206 ! 177 207 END SUBROUTINE dia_wri 178 208 … … 194 224 !! Each nwrite time step, output the instantaneous or mean fields 195 225 !!---------------------------------------------------------------------- 226 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 227 USE wrk_nemo, ONLY: zw2d => wrk_2d_1 228 !! 196 229 INTEGER, INTENT( in ) :: kt ! ocean time-step index 197 230 !! … … 201 234 INTEGER :: iimi, iima, ipk, it, itmod, ijmi, ijma ! local integers 202 235 REAL(wp) :: zsto, zout, zmax, zjulian, zdt ! local scalars 203 REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace204 236 !!---------------------------------------------------------------------- 237 ! 238 IF( wrk_in_use(2, 1))THEN 239 CALL ctl_stop('dia_wri: ERROR - requested 2D workspace unavailable.') 240 RETURN 241 END IF 205 242 ! 206 243 ! Output the initial state and forcings … … 502 539 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 503 540 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 504 zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1)541 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1) 505 542 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 506 543 #endif … … 508 545 CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping 509 546 CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping 510 zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1)547 IF( ln_ssr ) zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1) 511 548 CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping 512 549 #endif … … 570 607 CALL histclo( nid_W ) 571 608 ENDIF 609 ! 610 IF( wrk_not_released(2, 1))THEN 611 CALL ctl_stop('dia_wri: ERROR - failed to release 2D workspace.') 612 RETURN 613 END IF 572 614 ! 573 615 END SUBROUTINE dia_wri -
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diawri_dimg.h90
r2528 r2715 69 69 INTEGER ,INTENT(in) :: kt 70 70 !! 71 INTEGER :: inbsel, jk72 INTEGER :: iyear,imon,iday73 INTEGER, SAVE :: nmoyct74 75 71 #if defined key_diainstant 76 72 LOGICAL, PARAMETER :: ll_dia_inst=.TRUE. !: for instantaneous output … … 78 74 LOGICAL, PARAMETER :: ll_dia_inst=.FALSE. !: for average output 79 75 #endif 80 81 REAL(wp), SAVE, DIMENSION (jpi,jpj,jpk) :: um , vm ! used to compute mean u, v fields 82 REAL(wp), SAVE, DIMENSION (jpi,jpj,jpk) :: wm ! used to compute mean w fields 83 REAL(wp), SAVE, DIMENSION (jpi,jpj,jpk) :: avtm ! used to compute mean kz fields 84 REAL(wp), SAVE, DIMENSION (jpi,jpj,jpk) :: tm , sm ! used to compute mean t, s fields 85 REAL(wp), SAVE, DIMENSION (jpi,jpj,jpk) :: fsel ! used to compute mean 2d fields 76 INTEGER , SAVE :: nmoyct 77 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: um , vm, wm ! mean u, v, w fields 78 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: avtm ! mean kz fields 79 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: tm , sm ! mean t, s fields 80 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: fsel ! mean 2d fields 81 82 INTEGER :: inbsel, jk 83 INTEGER :: iyear,imon,iday 86 84 REAL(wp) :: zdtj 87 !88 85 CHARACTER(LEN=80) :: clname 89 86 CHARACTER(LEN=80) :: cltext … … 95 92 ! --------------- 96 93 ! 94 IF(.not.ALLOCATED(um))THEN 95 ALLOCATE(um(jpi,jpj,jpk), vm(jpi,jpj,jpk), & 96 wm(jpi,jpj,jpk), & 97 avtm(jpi,jpj,jpk), & 98 tm(jpi,jpj,jpk), sm(jpi,jpj,jpk), & 99 fsel(jpi,jpj,jpk), & 100 Stat=jk) 101 IF(jk /= 0)THEN 102 WRITE(*,*) 'ERROR: allocate failed in dia_wri (diawri_dimg.h90)' 103 CALL mppabort() 104 END IF 105 END IF 106 97 107 inbsel = 17 98 108 … … 247 257 cltext=TRIM(cexper)//' U(m/s) '//TRIM(clmode) 248 258 ! 249 IF( ll_dia_inst) THEN 250 CALL dia_wri_dimg(clname, cltext, un, jpk, 'T') 251 252 ELSE 253 CALL dia_wri_dimg(clname, cltext, um, jpk, 'T') 259 IF( ll_dia_inst) THEN ; CALL dia_wri_dimg(clname, cltext, un, jpk, 'T') 260 ELSE ; CALL dia_wri_dimg(clname, cltext, um, jpk, 'T') 254 261 ENDIF 255 262
Note: See TracChangeset
for help on using the changeset viewer.
