Changeset 3860
- Timestamp:
- 2013-04-06T12:32:03+02:00 (11 years ago)
- Location:
- branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM
- Files:
-
- 2 added
- 2 deleted
- 10 edited
-
CONFIG/ORCA2_LIM_CRS/EXP00/iodef.xml (modified) (1 diff)
-
CONFIG/ORCA2_LIM_CRS/MY_SRC/diawri.F90 (modified) (4 diffs)
-
CONFIG/ORCA2_LIM_CRS/MY_SRC/iom.F90 (modified) (1 diff)
-
CONFIG/ORCA2_LIM_CRS/MY_SRC/nemogcm.F90 (modified) (2 diffs)
-
CONFIG/ORCA2_LIM_CRS/cpp_ORCA2_LIM_CRS.fcm (modified) (1 diff)
-
NEMO/OPA_SRC/CRS/crs.F90 (modified) (1 diff)
-
NEMO/OPA_SRC/CRS/crs_dom.F90 (deleted)
-
NEMO/OPA_SRC/CRS/crs_iom.F90 (deleted)
-
NEMO/OPA_SRC/CRS/crsdiawri.F90 (modified) (5 diffs)
-
NEMO/OPA_SRC/CRS/crsdom.F90 (added)
-
NEMO/OPA_SRC/CRS/crsdomwri.F90 (modified) (9 diffs)
-
NEMO/OPA_SRC/CRS/crsini.F90 (modified) (13 diffs)
-
NEMO/OPA_SRC/CRS/crsiom.F90 (added)
-
NEMO/OPA_SRC/CRS/crslbclnk.F90 (modified) (2 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/CONFIG/ORCA2_LIM_CRS/EXP00/iodef.xml
r3809 r3860 448 448 <field ref="ssh_crs" name="sossheig" /> 449 449 <field ref="hdiv_crs" name="vohdiver" /> 450 <field ref="eken_crs" name="energkin" /> 450 451 </file> 451 452 -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/CONFIG/ORCA2_LIM_CRS/MY_SRC/diawri.F90
r3810 r3860 125 125 126 126 REAL(wp), POINTER, DIMENSION(:,:) :: z2d ! 2D workspace 127 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d 127 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d, z3d_1, zun2, zvn2 ! 3D workspace 128 128 !!---------------------------------------------------------------------- 129 129 ! … … 131 131 ! 132 132 CALL wrk_alloc( jpi , jpj , z2d ) 133 CALL wrk_alloc( jpi , jpj, jpk , z3d )133 CALL wrk_alloc( jpi , jpj, jpk , z3d, z3d_1, zun2, zvn2 ) 134 134 135 135 ! … … 140 140 ENDIF 141 141 142 !!cc 143 144 !!!! Calcul kinetic energy 145 146 147 148 zun2(:,:,:) = 0.e0 149 zvn2(:,:,:) = 0.e0 150 z3d(:,:,:) = 0.e0 151 z3d_1(:,:,:) = 0.e0 152 153 z3d(:,:,:) = un(:,:,:) * un(:,:,:) 154 z3d_1(:,:,:) = vn(:,:,:) * vn(:,:,:) 155 156 157 158 DO jk = 1, jpk 159 160 ! Calcul de U^2 pondéré 161 162 DO ji = 2, fs_jpim1 163 zun2(ji,:,jk) = 0.5 * ( z3d(ji-1,:,jk) * e1u(ji-1,:) * e2u(ji-1,:) * fse3u(ji-1,:,jk) & 164 & + z3d(ji ,:,jk) * e1u(ji ,:) * e2u(ji ,:) * fse3u(ji ,:,jk) ) & 165 & / ( e1t(ji ,: ) * e2t(ji ,:) * fse3t(ji ,:,jk) ) 166 ENDDO 167 168 169 ! Calcul de V^2 pondéré 170 171 DO jj = 2, jpjm1 172 zvn2(:,jj,jk) = 0.5 * ( z3d(:,jj-1,jk) * e1v(:,jj-1) * e2v(:,jj-1) * fse3v(:,jj-1,jk) & 173 & + z3d(:,jj ,jk) * e1v(:,jj ) * e2v(:,jj ) * fse3v(:,jj ,jk) ) & 174 & / ( e1t(:,jj ) * e2t(:,jj ) * fse3t(:,jj ,jk) ) 175 ENDDO 176 ENDDO 177 178 rke(:,:,:) = 0.5 * ( zun2(:,:,:) + zvn2(:,:,:) ) 179 180 181 ! DO jk = 1, jpk 182 ! DO jj = 1, jpj 183 ! DO ji = 1, jpi 184 ! z3d(ji,jj,jk) = un(ji,jj,jk) * un(ji,jj,jk) 185 ! z3d_1(ji,jj,jk) = vn(ji,jj,jk) * vn(ji,jj,jk) 186 ! ENDDO 187 ! ENDDO 188 ! ENDDO 189 190 ! DO jk = 1, jpk 191 ! DO jj = 2, jpjm1 192 ! DO ji = 2, fs_jpim1 193 ! zun2(ji,jj,jk) = 0.5 * ( z3d(ji-1,jj,jk) + z3d(ji,jj,jk) ) 194 ! zvn2(ji,jj,jk) = 0.5 * ( z3d_1(ji,jj-1,jk) + z3d_1(ji,jj,jk) ) 195 ! rke(ji,jj,jk) = 0.5 * ( zun2(ji,jj,jk) + zvn2(ji,jj,jk) ) ! Calcul kinetic energy 196 ! ENDDO 197 ! ENDDO 198 ! ENDDO 199 200 CALL lbc_lnk( rke, 'T', 1.0 ) 201 202 !!cc test 203 ! CALL iom_put( "testU" , z3d(:,:,:)) 204 ! CALL iom_put( "testV" , z3d_1(:,:,:)) 205 !!cc test 206 CALL iom_put( "eken" , rke(:,:,:) ) ! kinetic energy 142 207 CALL iom_put( "toce" , tsn(:,:,:,jp_tem) ) ! temperature 143 208 CALL iom_put( "soce" , tsn(:,:,:,jp_sal) ) ! salinity … … 203 268 ENDIF 204 269 ! 205 ! Calcul kinetic energy206 DO jk = 1, jpkm1207 DO jj = 2, jpjm1208 DO ji = fs_2, fs_jpim1 ! vector opt.209 zztmp = 1._wp / ( e1e2t(ji,jj) * fse3t(ji,jj,jk) )210 zztmpx = 0.5 * ( un(ji-1,jj,jk) * un(ji-1,jj,jk) * e2u(ji-1,jj) * fse3u(ji-1,jj,jk) &211 & + un(ji ,jj,jk) * un(ji ,jj,jk) * e2u(ji ,jj) * fse3u(ji ,jj,jk) ) &212 & * zztmp213 !214 zztmpy = 0.5 * ( vn(ji,jj-1,jk) * vn(ji,jj-1,jk) * e1v(ji,jj-1) * fse3v(ji,jj-1,jk) &215 & + vn(ji,jj ,jk) * vn(ji,jj ,jk) * e1v(ji,jj ) * fse3v(ji,jj ,jk) ) &216 & * zztmp217 !218 rke(ji,jj,jk) = 0.5 * ( zztmpx + zztmpy )219 !220 ENDDO221 ENDDO222 ENDDO223 CALL lbc_lnk( rke, 'T', 1. )224 CALL iom_put( "eken", rke ) ! Kinetic energy225 !226 270 CALL wrk_dealloc( jpi , jpj , z2d ) 227 CALL wrk_dealloc( jpi , jpj, jpk , z3d )271 CALL wrk_dealloc( jpi , jpj, jpk , z3d, z3d_1, zun2, zvn2 ) 228 272 ! 229 273 IF( nn_timing == 1 ) CALL timing_stop('dia_wri') -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/CONFIG/ORCA2_LIM_CRS/MY_SRC/iom.F90
r3779 r3860 37 37 USE mod_attribut 38 38 # endif 39 USE crs _dom39 USE crs 40 40 41 41 IMPLICIT NONE -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/CONFIG/ORCA2_LIM_CRS/MY_SRC/nemogcm.F90
r3727 r3860 332 332 ! ! Grid coarsening 333 333 IF( ln_crs ) CALL crs_init ! Domain initialization of coarsened grid 334 !! Ocean physics334 ! Ocean physics 335 335 CALL sbc_init ! Forcings : surface module 336 336 337 ! ! Vertical physics 337 338 CALL zdf_init ! namelist read … … 532 533 ierr = ierr + zdf_oce_alloc () ! ocean vertical physics 533 534 ! 534 ierr = ierr + lib_mpp_alloc (numout) ! mpp exchanges535 535 ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays 536 536 !jes IF( ln_crs ) ierr = ierr + crs_dia_wri_alloc() ! standard output on coarse grid -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/CONFIG/ORCA2_LIM_CRS/cpp_ORCA2_LIM_CRS.fcm
r3622 r3860 1 bld::tool::fppkeys key_trabbl key_orca_r2 key_lim2 key_dynspg_flt key_diaeiv key_ldfslp key_traldf_c2d key_traldf_eiv key_dynldf_c3d key_zdftke key_zdfddm key_iomput 1 bld::tool::fppkeys key_trabbl key_orca_r2 key_lim2 key_dynspg_flt key_diaeiv key_ldfslp key_traldf_c2d key_traldf_eiv key_dynldf_c3d key_zdftke key_zdfddm key_iomput key_mpp_mpi -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90
r3823 r3860 1 MODULE crs 2 !!=================================================================== 3 !! *** crs.F90 *** 4 !! Purpose: Interface for calculating quantities from a 5 !! higher-resolution grid for the coarse grid. 6 !! 7 !! Method: Given the user-defined reduction factor, 8 !! the averaging bins are set: 9 !! - cn_binref = NORTH, starting from the north 10 !! to the south in the model interior domain, 11 !! in this way the north fold and redundant halo cells 12 !! could be handled in a consistent manner and 13 !! the irregularities of bin size can be handled 14 !! more naturally by the presence of land 15 !! in the southern boundary. Thus the southernmost bin 16 !! could be of an irregular bin size. 17 !! Information on the parent grid is retained, specifically, 18 !! each coarse grid cell's volume and ocean surface 19 !! at the faces, relative to the parent grid. 20 !! - cn_binref = EQUAT (not yet available), starting 21 !! at a centralized bin at the equator, being only 22 !! truly centered for odd-numbered j-direction reduction 23 !! factors. 24 !! References: Aumont, O., J.C. Orr, D. Jamous, P. Monfray 25 !! O. Marti and G. Madec, 1998. A degradation 26 !! approach to accelerate simulations to steady-state 27 !! in a 3-D tracer transport model of the global ocean. 28 !! Climate Dynamics, 14:101-116. 29 !! History: 30 !! Original. May 2012. (J. Simeon, G. Madec, C. Ethe) 31 !!=================================================================== 32 33 USE dom_oce ! ocean space and time domain and to get jperio 34 USE wrk_nemo ! work arrays 35 USE crs_dom ! domain for coarse grid 36 USE in_out_manager 37 USE par_kind, ONLY: wp 38 USE crslbclnk 1 MODULE crs 2 !!====================================================================== 3 !! *** MODULE crs_dom *** 4 !! Declare the coarse grid domain and other public variables 5 !! then allocate them if needed. 6 !!====================================================================== 7 !! History 2012-06 Editing (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code 8 !!---------------------------------------------------------------------- 9 USE par_oce 10 USE dom_oce 11 USE in_out_manager 12 13 14 IMPLICIT NONE 15 PUBLIC 16 39 17 40 41 IMPLICIT NONE 42 43 PRIVATE 44 45 PUBLIC crsfun, crs_e3_max, crs_surf 46 47 INTERFACE crsfun 48 MODULE PROCEDURE crsfun_mask, crsfun_coordinates, crsfun_wgt, crsfun_UV, crsfun_TW 49 END INTERFACE 50 51 !! Substitutions 52 # include "domzgr_substitute.h90" 18 PUBLIC crs_dom_alloc ! Called from crsini.F90 19 PUBLIC dom_grid_glo 20 PUBLIC dom_grid_crs 21 22 ! Domain variables 23 INTEGER :: jpiglo_crs , & !: 1st dimension of global coarse grid domain 24 jpjglo_crs !: 2nd dimension of global coarse grid domain 25 INTEGER :: jpi_crs , & !: 1st dimension of local coarse grid domain 26 jpj_crs !: 2nd dimension of local coarse grid domain 27 INTEGER :: jpi_full , & !: 1st dimension of local parent grid domain 28 jpj_full !: 2nd dimension of local parent grid domain 29 30 INTEGER :: nistart, njstart 31 INTEGER :: niend , njend 32 33 INTEGER :: jpi_crsm1, jpj_crsm1 !: loop indices 34 INTEGER :: jpiglo_crsm1, jpjglo_crsm1 !: loop indices 35 INTEGER :: nperio_full, nperio_crs !: jperio of parent and coarse grids 36 INTEGER :: npolj_full, npolj_crs !: north fold mark 37 INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo 38 INTEGER :: npiglo, npjglo !: jpjglo 39 INTEGER :: nlci_full, nlcj_full !: i-, j-dimension of local or sub domain on parent grid 40 INTEGER :: nldi_full, nldj_full !: starting indices of internal sub-domain on parent grid 41 INTEGER :: nlei_full, nlej_full !: ending indices of internal sub-domain on parent grid 42 INTEGER :: nlci_crs, nlcj_crs !: i-, j-dimension of local or sub domain on coarse grid 43 INTEGER :: nldi_crs, nldj_crs !: starting indices of internal sub-domain on coarse grid 44 INTEGER :: nlei_crs, nlej_crs !: ending indices of internal sub-domain on coarse grid 45 INTEGER :: narea_full, narea_crs !: node 46 INTEGER :: jpnij_full, jpnij_crs !: =jpni*jpnj, the pe decomposition 47 INTEGER :: jpim1_full, jpjm1_full !: 48 INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid 49 INTEGER :: nimpp_crs, njmpp_crs !: set to 1,1 for now . Valid only for monoproc 50 INTEGER :: nreci_full, nrecj_full 51 INTEGER :: nreci_crs, nrecj_crs 52 !cc 53 INTEGER :: noea_full, nowe_full !: index of the local neighboring processors in 54 INTEGER :: noso_full, nono_full !: east, west, south and north directions 55 INTEGER :: npne_full, npnw_full !: index of north east and north west processor 56 INTEGER :: npse_full, npsw_full !: index of south east and south west processor 57 INTEGER :: nbne_full, nbnw_full !: logical of north east & north west processor 58 INTEGER :: nbse_full, nbsw_full !: logical of south east & south west processor 59 INTEGER :: nidom_full !: ??? 60 INTEGER :: nproc_full !:number for local processor 61 INTEGER :: nbondi_full, nbondj_full !: mark of i- and j-direction local boundaries 62 INTEGER :: noea_crs, nowe_crs !: index of the local neighboring processors in 63 INTEGER :: noso_crs, nono_crs !: east, west, south and north directions 64 INTEGER :: npne_crs, npnw_crs !: index of north east and north west processor 65 INTEGER :: npse_crs, npsw_crs !: index of south east and south west processor 66 INTEGER :: nbne_crs, nbnw_crs !: logical of north east & north west processor 67 INTEGER :: nbse_crs, nbsw_crs !: logical of south east & south west processor 68 INTEGER :: nidom_crs !: ??? 69 INTEGER :: nproc_crs !:number for local processor 70 INTEGER :: nbondi_crs, nbondj_crs !: mark of i- and j-direction local boundaries 71 72 73 INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mis2_crs, mie2_crs ! starting and ending i-indices of parent subset 74 INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs, mjs2_crs, mje2_crs ! starting and ending j-indices of parent subset 75 INTEGER, DIMENSION(:), ALLOCATABLE :: mjg_crs, mig_crs 76 INTEGER :: mxbinctr, mybinctr ! central point in grid box 77 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit_crs, nlcit_full !: dimensions of every subdomain 78 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit_crs, nldit_full !: first, last indoor index for each i-domain 79 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit_crs, nleit_full !: first, last indoor index for each j-domain 80 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain 81 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcjt_crs, nlcjt_full !: dimensions of every subdomain 82 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldjt_crs, nldjt_full !: first, last indoor index for each i-domain 83 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlejt_crs, nlejt_full !: first, last indoor index for each j-domain 84 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain 85 86 87 ! Masks 88 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs 89 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmask_i_crs, rnfmsk_crs, tpol_crs, fpol_crs 90 91 ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmask_i_crs, tpol, fpol 92 93 ! Scale factors 94 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1t_crs, e2t_crs, e1e2t_crs ! horizontal scale factors grid type T 95 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1u_crs, e2u_crs ! horizontal scale factors grid type U 96 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1v_crs, e2v_crs ! horizontal scale factors grid type V 97 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: e1f_crs, e2f_crs ! horizontal scale factors grid type F 98 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_crs, e3u_crs, e3v_crs, e3f_crs, e3w_crs 99 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: fse3t_crs, fse3u_crs, fse3v_crs, fse3f_crs, fse3w_crs 100 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: fse3t_n_crs, fse3t_b_crs, fse3t_a_crs 101 102 ! Surface 103 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e1e2w_msk, e2e3u_msk, e1e3v_msk, e1e2w, e2e3u, e1e3v 104 ! vertical scale factors 105 ! Coordinates 106 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs 107 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs 108 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ff_crs 109 INTEGER, DIMENSION(:,:), ALLOCATABLE :: mbathy_crs, mbkt_crs, mbku_crs, mbkv_crs 110 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs 111 112 ! Weights 113 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: facsurfv, facsurfu, facvol_t, facvol_w 114 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ocean_volume_crs_t, ocean_volume_crs_w, bt_crs, r1_bt_crs 115 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: crs_surfu_wgt, crs_surfv_wgt, crs_surfw_wgt, crs_volt_wgt 116 117 ! CRS Namelist 118 INTEGER :: nn_factx = 3 !: reduction factor of x-dimension of the parent grid 119 INTEGER :: nn_facty = 3 !: reduction factor of y-dimension of the parent grid 120 CHARACTER(len=5) :: cn_binref = 'NORTH' !: NORTH = binning starts north fold (equator could be asymmetric) 121 !: EQUAT = binning centers at equator (north fold my have artifacts) 122 !: for even reduction factors, equator placed in bin biased south 123 INTEGER :: nn_fcrs = 3 !: frequence of coarsening 124 INTEGER :: nn_msh_crs = 1 !: Organization of mesh mask output 125 !: 0 = no mesh mask output 126 !: 1 = unified mesh mask output 127 !: 2 = 2 separate mesh mask output 128 !: 3 = 3 separate mesh mask output 129 CHARACTER(len=11) :: cn_ocerstcrs !: root name of restart files for coarsened variables 130 131 INTEGER :: nrestx, nresty !: for determining odd or even reduction factor 132 133 ! Grid reduction factors 134 REAL(wp) :: rfactx_r !: inverse of x-dim reduction factor 135 REAL(wp) :: rfacty_r !: inverse of y-dim reduction factor 136 REAL(wp) :: rfactxy 137 138 !! Horizontal grid parameters for domhgr 139 !! ===================================== 140 INTEGER :: nphgr_msh_crs = 0 !: type of horizontal mesh 141 ! ! = 0 curvilinear coordinate on the sphere read in coordinate.nc 142 ! ! = 1 geographical mesh on the sphere with regular grid-spacing 143 ! ! = 2 f-plane with regular grid-spacing 144 ! ! = 3 beta-plane with regular grid-spacing 145 ! ! = 4 Mercator grid with T/U point at the equator 146 147 ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields 148 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsn_crs 149 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: un_crs, vn_crs, wn_crs, rke_crs 150 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivn_crs 151 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: sshn_crs 152 153 ! 154 ! Surface fluxes to pass to TOP 155 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: wndm_crs, qsr_crs, emp_crs, emps_crs 156 157 ! Vertical diffusion 158 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_crs !: vert. diffusivity coef. [m2/s] at w-point for temp 159 # if defined key_zdfddm 160 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avs_crs !: salinity vertical diffusivity coeff. [m2/s] at w-point 161 # endif 162 163 ! Mixing and Mixed Layer Depth 164 INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs 165 166 ! Direction of lateral diffusion 167 168 169 CONTAINS 53 170 54 CONTAINS 55 56 SUBROUTINE crsfun_mask( p_ptmask, cd_type, p_cmask ) 57 !!---------------------------------------------------------------- 58 !! *** SUBROUTINE crsfun_mask *** 59 !! ** Purpose : Computes the 3D tmask of the coarse grid 171 INTEGER FUNCTION crs_dom_alloc() 172 !!------------------------------------------------------------------- 173 !! *** FUNCTION crs_dom_alloc *** 174 !! ** Purpose : Allocate public crs arrays 175 !!------------------------------------------------------------------- 176 !! Local variables 177 INTEGER, DIMENSION(17) :: ierr 178 179 ierr(:) = 0 180 181 ! Set up bins for coarse grid, horizontal only. 182 ALLOCATE( mis2_crs(jpiglo_crs) , mie2_crs(jpiglo_crs) , mjs2_crs(jpjglo_crs) , mje2_crs(jpjglo_crs),& 183 & mig_crs(jpi_crs), mjg_crs(jpj_crs), STAT=ierr(1) ) 184 185 ! Set up Mask and Mesh 186 187 ALLOCATE( tmask_crs(jpi_crs,jpj_crs,jpk) , fmask_crs(jpi_crs,jpj_crs,jpk) , & 188 & umask_crs(jpi_crs,jpj_crs,jpk) , vmask_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(2)) 189 190 ALLOCATE( tmask_i_crs(jpi_crs,jpj_crs), rnfmsk_crs(jpi_crs,jpj_crs), & 191 & tpol_crs(jpiglo_crs,jpjglo_crs), fpol_crs(jpiglo_crs,jpjglo_crs), STAT=ierr(3) ) 192 193 ALLOCATE( gphit_crs(jpi_crs,jpj_crs) , glamt_crs(jpi_crs,jpj_crs) , & 194 & gphiu_crs(jpi_crs,jpj_crs) , glamu_crs(jpi_crs,jpj_crs) , & 195 & gphiv_crs(jpi_crs,jpj_crs) , glamv_crs(jpi_crs,jpj_crs) , & 196 & gphif_crs(jpi_crs,jpj_crs) , glamf_crs(jpi_crs,jpj_crs) , & 197 & ff_crs(jpi_crs,jpj_crs) , STAT=ierr(4)) 198 199 ALLOCATE( e1t_crs(jpi_crs,jpj_crs) , e2t_crs(jpi_crs,jpj_crs) , & 200 & e1u_crs(jpi_crs,jpj_crs) , e2u_crs(jpi_crs,jpj_crs) , & 201 & e1v_crs(jpi_crs,jpj_crs) , e2v_crs(jpi_crs,jpj_crs) , & 202 & e1f_crs(jpi_crs,jpj_crs) , e2f_crs(jpi_crs,jpj_crs) , & 203 & e1e2t_crs(jpi_crs,jpj_crs), STAT=ierr(5)) 204 205 ALLOCATE( fse3t_crs(jpi_crs,jpj_crs,jpk) , fse3w_crs(jpi_crs,jpj_crs,jpk) , & 206 & fse3u_crs(jpi_crs,jpj_crs,jpk) , fse3v_crs(jpi_crs,jpj_crs,jpk) , & 207 & e3t_crs(jpi_crs,jpj_crs,jpk) , e3w_crs(jpi_crs,jpj_crs,jpk) , & 208 & e3u_crs(jpi_crs,jpj_crs,jpk) , e3v_crs(jpi_crs,jpj_crs,jpk) , & 209 & e3f_crs(jpi_crs,jpj_crs,jpk) , fse3f_crs(jpi_crs,jpj_crs,jpk) , & 210 & fse3t_b_crs(jpi_crs,jpj_crs,jpk), fse3t_n_crs(jpi_crs,jpj_crs,jpk),& 211 & fse3t_a_crs(jpi_crs,jpj_crs,jpk), e1e2w_msk(jpi_crs,jpj_crs,jpk) , & 212 & e2e3u_msk(jpi_crs,jpj_crs,jpk) , e1e3v_msk(jpi_crs,jpj_crs,jpk) , & 213 & e1e2w(jpi_crs,jpj_crs,jpk) , e2e3u(jpi_crs,jpj_crs,jpk) , & 214 & e1e3v(jpi_crs,jpj_crs,jpk) , STAT=ierr(6)) 215 216 217 ALLOCATE( facsurfv(jpi_crs,jpj_crs,jpk) , facsurfu(jpi_crs,jpj_crs,jpk) , & 218 & facvol_t(jpi_crs,jpj_crs,jpk) , facvol_w(jpi_crs,jpj_crs,jpk) , & 219 & ocean_volume_crs_t(jpi_crs,jpj_crs,jpk) , ocean_volume_crs_w(jpi_crs,jpj_crs,jpk), & 220 & bt_crs(jpi_crs,jpj_crs,jpk) , r1_bt_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(7)) 221 222 223 ALLOCATE( crs_surfu_wgt(jpi_crs,jpj_crs,jpk) , crs_surfv_wgt(jpi_crs,jpj_crs,jpk) , & 224 & crs_surfw_wgt(jpi_crs,jpj_crs,jpk) , crs_volt_wgt(jpi_crs,jpj_crs,jpk) , STAT=ierr(8)) 225 226 227 ALLOCATE( mbathy_crs(jpi_crs,jpj_crs) , mbkt_crs(jpi_crs,jpj_crs) , & 228 & mbku_crs(jpi_crs,jpj_crs) , mbkv_crs(jpi_crs,jpj_crs) , STAT=ierr(9)) 229 230 ALLOCATE( gdept_crs(jpi_crs,jpj_crs,jpk) , gdepu_crs(jpi_crs,jpj_crs,jpk) , & 231 & gdepv_crs(jpi_crs,jpj_crs,jpk) , gdepw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(10) ) 232 233 234 ALLOCATE( un_crs(jpi_crs,jpj_crs,jpk) , vn_crs(jpi_crs,jpj_crs,jpk) , & 235 & wn_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk),& 236 & rke_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(11)) 237 238 ALLOCATE( sshn_crs(jpi_crs,jpj_crs), emp_crs(jpi_crs,jpj_crs) , & 239 & qsr_crs(jpi_crs,jpj_crs) , wndm_crs(jpi_crs,jpj_crs) , & 240 & emps_crs(jpi_crs,jpj_crs), STAT=ierr(12) ) 241 242 ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), & 243 # if defined key_zdfddm 244 & avs_crs(jpi_crs,jpj_crs,jpk), & 245 # endif 246 & STAT=ierr(13) ) 247 248 ALLOCATE( nmln_crs(jpi_crs,jpj_crs) , hmld_crs(jpi_crs,jpj_crs) , & 249 & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) 250 251 ALLOCATE( nimppt_crs(jpnij) , nlcit_crs(jpnij) , nldit_crs(jpnij) , nleit_crs(jpnij), & 252 & nimppt_full(jpnij) , nlcit_full(jpnij) , nldit_full(jpnij) , nleit_full(jpnij), & 253 njmppt_crs(jpnij) , nlcjt_crs(jpnij) , nldjt_crs(jpnij) , nlejt_crs(jpnij), & 254 & njmppt_full(jpnij) , nlcjt_full(jpnij) , nldjt_full(jpnij) , nlejt_full(jpnij) , STAT=ierr(15) ) 255 256 257 crs_dom_alloc = MAXVAL(ierr) 258 259 END FUNCTION crs_dom_alloc 260 261 INTEGER FUNCTION crs_dom_alloc2() 262 !!------------------------------------------------------------------- 263 !! *** FUNCTION crs_dom_alloc *** 264 !! ** Purpose : Allocate public crs arrays 265 !!------------------------------------------------------------------- 266 !! Local variables 267 INTEGER, DIMENSION(1) :: ierr 268 269 ierr(:) = 0 270 271 ALLOCATE( mjs_crs(nlej_crs) , mje_crs(nlej_crs), mis_crs(nlei_crs) , mie_crs(nlei_crs), STAT=ierr(1) ) 272 crs_dom_alloc2 = MAXVAL(ierr) 273 274 END FUNCTION crs_dom_alloc2 275 276 SUBROUTINE dom_grid_glo 277 !!-------------------------------------------------------------------- 278 !! *** MODULE dom_grid_glo *** 60 279 !! 61 !! ** Method : The subset of the parent grid tmask comprising 62 !! the new, coarsened grid box is examined for 63 !! the presence of an ocean mask point. If, at 64 !! minimum, one ocean mask point is found, the 65 !! new coarsened grid box becomes set to ocean (tmask=1) 66 !! The tmask is first determined, then from 67 !! the coarse-grid tmask, the umask, vmask and fmask are 68 !! derived. 69 !! ** Input : p_ptmask = 3D parent grid tmask 70 !! cd_type = grid type ('T', 'U', 'V', 'F') 71 !! p_pmask2d = (Optional) parent 2D mask (i.e. runoff mask) 72 !! ** Output : p_cmask = (Optional) 3D coarsened grid [t|u|v|f]mask 73 !! p_cmask2d = (Optional) 2D coarsened grid [t|u|v|f]mask 74 !! History. 29 May 2012. 2nd draft done. Do u,v,f masks here or in crsini? 75 !! 31 May 2012. Redid umask,vmask, fmask creation to take into account blocked 76 !! faces. 77 !!---------------------------------------------------------------- 78 ! Arguments 79 REAL, DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_ptmask ! Parent grid tmask 80 CHARACTER(len=1) , INTENT(in) :: cd_type ! grid type (T,U,V,F) 81 REAL, DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_cmask ! Coarse grid [t,u,v,f]mask 82 83 84 ! Local variables 85 INTEGER :: ji, jj, jk, ijpk ! dummy loop indices 86 INTEGER :: ijie,ijis,ijje,ijjs 87 88 ! Initialize 89 DO jk = 1, jpk 90 DO ji = 2, nlei_crs - 1 91 ijie = mie_crs(ji) 92 ijis = mis_crs(ji) 93 94 DO jj = njstart, njend 95 ijje = mje_crs(jj) 96 ijjs = mjs_crs(jj) 97 98 IF ( cd_type == 'T' ) THEN 99 p_cmask(ji,jj,jk) = SUM( p_ptmask(ijis:ijie,ijjs:ijje,jk) ) 100 IF ( p_cmask(ji,jj,jk) > 0 ) p_cmask(ji,jj,jk) = 1 101 ELSEIF ( cd_type == 'V' ) THEN 102 p_cmask(ji,jj,jk) = SUM( p_ptmask(ijis:ijie,ijje,jk) * p_ptmask(ijis:ijie,ijje+1,jk) ) 103 IF ( p_cmask(ji,jj,jk) > 0 ) p_cmask(ji,jj,jk) = 1 104 ELSEIF ( cd_type == 'U' ) THEN 105 p_cmask(ji,jj,jk) = SUM( p_ptmask(ijie,ijjs:ijje,jk) * p_ptmask(ijie+1,ijjs:ijje,jk) ) 106 IF ( p_cmask(ji,jj,jk) > 0 ) p_cmask(ji,jj,jk) = 1 107 ELSE ! fmask 108 p_cmask(ji,jj,jk) = p_ptmask(ijie,ijje,jk) + p_ptmask(ijie+1,ijje,jk) & 109 & + p_ptmask(ijie,ijje+1,jk) + p_ptmask(ijie+1,ijje+1,jk) 110 IF ( p_cmask(ji,jj,jk) > 0 ) p_cmask(ji,jj,jk) = 1 111 ENDIF 112 113 ENDDO 114 ENDDO 115 ENDDO 116 117 118 ! Retroactively add back the halo cells j=1, j=jpj_crs and i=1, i=jpi_crs. 119 120 IF( nperio /= 0 ) THEN 121 CALL crs_lbc_lnk( cd_type,1.0,pt3d1=p_cmask ) 122 ELSE 123 p_cmask( 1 ,: ,:) = p_cmask( 2,: ,:) ! all points 124 p_cmask(jpi_crs,:,:) = p_cmask(jpi_crsm1,:,:) 125 p_cmask( :,1 ,:) = p_cmask( :,2 ,:) 126 p_cmask(:,jpj_crs,:) = p_cmask(:,jpj_crsm1,:) 127 ENDIF 128 129 130 END SUBROUTINE crsfun_mask 131 132 SUBROUTINE crsfun_coordinates( p_pgphi, p_pglam, cd_type, p_cgphi, p_cglam ) 133 !!---------------------------------------------------------------- 134 !! *** SUBROUTINE crsfun_coordinates *** 135 !! ** Purpose : Determine the coordinates for the coarse grid 136 !! 137 !! ** Method : From the parent grid subset, search for the central 138 !! point. For an odd-numbered reduction factor, 139 !! the coordinate will be that of the central T-cell. 140 !! For an even-numbered reduction factor, of a non-square 141 !! coarse grid box, the coordinate will be that of 142 !! the east or north face or more likely. For a square 143 !! coarse grid box, the coordinate will be that of 144 !! the central f-corner. 280 !! ** Purpose : +Return back to parent grid domain 281 !!--------------------------------------------------------------------- 282 283 ! Return to parent grid domain 284 jpi = jpi_full 285 jpj = jpj_full 286 jpim1 = jpim1_full 287 jpjm1 = jpjm1_full 288 nperio = nperio_full 289 290 npolj = npolj_full 291 jpiglo = jpiglo_full 292 jpjglo = jpjglo_full 293 294 nlci = nlci_full 295 nlcj = nlcj_full 296 nldi = nldi_full 297 nldj = nldj_full 298 nlei = nlei_full 299 nlej = nlej_full 300 nimpp = nimpp_full 301 njmpp = njmpp_full 302 303 nlcit(:) = nlcit_full(:) 304 nldit(:) = nldit_full(:) 305 nleit(:) = nleit_full(:) 306 nimppt(:) = nimppt_full(:) 307 nlcjt(:) = nlcjt_full(:) 308 nldjt(:) = nldjt_full(:) 309 nlejt(:) = nlejt_full(:) 310 njmppt(:) = njmppt_full(:) 311 312 313 314 315 END SUBROUTINE dom_grid_glo 316 317 SUBROUTINE dom_grid_crs 318 !!-------------------------------------------------------------------- 319 !! *** MODULE dom_grid_crs *** 145 320 !! 146 !! ** Input : p_pgphi = parent grid gphi[t|u|v|f] 147 !! p_pglam = parent grid glam[t|u|v|f] 148 !! cd_type = grid type (T,U,V,F) 149 !! ** Output : p_cgphi = coarse grid gphi[t|u|v|f] 150 !! p_cglam = coarse grid glam[t|u|v|f] 151 !! 152 !! History. 1 Jun. 153 !!---------------------------------------------------------------- 154 !! Arguments 155 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_pgphi ! Parent grid latitude 156 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_pglam ! Parent grid longitude 157 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type (T,U,V,F) 158 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_cgphi ! Coarse grid latitude 159 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_cglam ! Coarse grid longitude 160 161 !! Local variables 162 INTEGER :: ji, jj, jk ! dummy loop indices 163 INTEGER :: ijie,ijis,ijje,ijjs,ijpk 164 165 166 !! Initialize output fields 167 p_cgphi(:,:) = 0.e0 168 p_cglam(:,:) = 0.e0 169 170 171 DO ji = 2, nlei_crs - 1 172 173 IF ( cd_type == 'T' .OR. cd_type == 'V' ) ijis = mis_crs(ji) + mxbinctr 174 IF ( cd_type == 'U' .OR. cd_type == 'F' ) ijis = mie_crs(ji) 175 176 DO jj = njstart, njend 177 178 IF ( cd_type == 'T' .OR. cd_type == 'U' ) ijjs = mjs_crs(jj) + mybinctr 179 IF ( cd_type == 'V' .OR. cd_type == 'F' ) ijjs = mje_crs(jj) 180 181 p_cgphi(ji,jj) = p_pgphi(ijis,ijjs) 182 p_cglam(ji,jj) = p_pglam(ijis,ijjs) 183 184 ENDDO 185 186 ENDDO 187 188 189 ! Retroactively add back the boundary halo cells. 190 191 IF( nperio /= 0 ) THEN 192 CALL crs_lbc_lnk( cd_type,1.0,p_cgphi ) 193 CALL crs_lbc_lnk( cd_type,1.0,p_cglam ) 194 ELSE 195 p_cgphi( 1,:) = p_cgphi(2 ,:) ! all points 196 p_cgphi(jpi_crs,:) = p_cgphi(jpi_crsm1,:) 197 p_cgphi( :,1) = p_cgphi( :,2) 198 p_cgphi(:,jpj_crs) = p_cgphi(:,jpj_crsm1) 199 200 p_cglam( 1,:) = p_cglam( 2,:) ! all points 201 p_cglam(jpi_crs,:) = p_cglam(jpi_crsm1,:) 202 p_cglam( :,1) = p_cglam( :,2) 203 p_cglam(:,jpj_crs) = p_cglam(:,jpj_crsm1) 204 205 ENDIF 206 207 ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 208 DO ji = 2, nlei_crs - 1 209 210 IF ( cd_type == 'T' .OR. cd_type == 'V' ) ijis = mis_crs(ji) + mxbinctr 211 IF ( cd_type == 'U' .OR. cd_type == 'F' ) ijis = mie_crs(ji) 212 213 p_cgphi(ji,1) = p_pgphi(ijis,1) 214 p_cglam(ji,1) = p_pglam(ijis,1) 215 216 ENDDO 217 218 ! Fill i=1, i=jpi at j=1 219 p_cgphi(1,1) = p_cgphi(jpi_crsm1,1) 220 p_cglam(1,1) = p_cglam(jpi_crsm1,1) 221 p_cgphi(jpi_crs,1) = p_cgphi(2,1) 222 p_cglam(jpi_crs,1) = p_cglam(2,1) 223 ! Fill upper-right corner i=1, j=jpj_crs 224 !cc IF ( nperio == 4 ) THEN 225 !cc p_cgphi(1,jpj_crs) = p_cgphi(jpi_crsm1,jpj_crs-2) 226 !cc p_cglam(1,jpj_crs) = p_cglam(jpi_crsm1,jpj_crs-2) 227 !cc ELSEIF ( nperio == 6 ) THEN 228 !cc p_cgphi(1,jpj_crs) = p_cgphi(jpi_crs,jpj_crsm1) 229 !cc p_cglam(1,jpj_crs) = p_cglam(jpi_crs,jpj_crsm1) 230 !cc ENDIF 231 232 END SUBROUTINE crsfun_coordinates 233 234 SUBROUTINE crsfun_wgt( cd_type, cd_op, p_pmask, p_e1, p_e2, p_fse3, & 235 & p_cfield2d_1, p_cfield2d_2, p_cfield3d_1, p_cfield3d_2 ) 236 !!---------------------------------------------------------------- 237 !! *** SUBROUTINE crsfun_wgt *** 238 !! ** Purpose : Three applications. 239 !! 1) SUM. Get coarse grid horizontal scale factors and unmasked fraction 240 !! 2) VOL. Get coarse grid box volumes 241 !! 3) WGT. Weighting multiplier for volume-weighted and/or 242 !! area-weighted averages. 243 !! Weights (i.e. the denominator) calculated here 244 !! to avoid IF-tests and division. 245 !! ** Method : 1) SUM. For grid types T,U,V,F (and W) the 2D scale factors of 246 !! the coarse grid are the sum of the east or north faces of the 247 !! parent grid subset comprising the coarse grid box. 248 !! The fractions of masked:total surface (3D) on the east, 249 !! north and top faces is, optionally, also output. 250 !! - Top face area sum 251 !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 252 !! - Top face ocean surface fraction 253 !! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2 254 !! - e1,e2 Scale factors 255 !! Valid arguments: 256 !! 2) VOL. For grid types W and T, the coarse grid box 257 !! volumes are output. Also optionally, the fraction of 258 !! masked:total volume of the parent grid subset is output (i.e. facvol). 259 !! 3) WGT. Based on the grid type, the denominator is pre-determined here to 260 !! perform area- or volume- weighted averages, 261 !! to avoid IF-tests and divisions. 262 !! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f) 263 !! p_pmask = parent grid mask (T,U,V,F) 264 !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) 265 !! cd_op = applied operation (SUM, VOL, WGT) 266 !! p_fse3 = (Optional) parent grid vertical level thickness (fse3u or fse3v) 267 !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid 268 !! p_cfield2d_2 = (Optional) 2D field on coarse grid 269 !! p_cfield3d_1 = (Optional) 3D field on coarse grid 270 !! p_cfield3d_2 = (Optional) 3D field on coarse grid 271 !! 272 !! History. 4 Jun. Write for WGT and scale factors only 273 !!---------------------------------------------------------------- 274 !! 275 !! Arguments 276 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V 277 CHARACTER(len=3), INTENT(in) :: cd_op ! operation sum or average 278 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_pmask ! Parent grid U,V mask 279 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1) 280 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2) 281 282 REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL :: p_cfield2d_1 ! Coarse grid box 2D quantity 283 REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL :: p_cfield2d_2 ! Coarse grid box 2D quantity 284 REAL(wp), DIMENSION(:,:,:), INTENT(out), OPTIONAL :: p_cfield3d_1 ! Coarse grid box 3D quantity 285 REAL(wp), DIMENSION(:,:,:), INTENT(out), OPTIONAL :: p_cfield3d_2 ! Coarse grid box 3D quantity 286 287 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_fse3 ! Parent grid vertical level thickness (fse3u, fse3v) 288 289 !! Local variables 290 INTEGER :: ji, jj, jk, jii, jjj ! dummy loop indices 291 INTEGER :: ijie,ijis,ijje,ijjs,ijpk 292 REAL(wp) :: zdAm ! masked face area 293 REAL(wp), DIMENSION(:,:), POINTER :: ze1, ze2 294 REAL(wp), DIMENSION(:,:,:), POINTER :: ze3 295 REAL(wp), DIMENSION(:,:), POINTER :: zcfield2d_1, zcfield2d_2 296 REAL(wp), DIMENSION(:,:,:), POINTER :: zcfield3d_1, zcfield3d_2 297 298 !!---------------------------------------------------------------- 299 ! Initialize 300 301 ! Arrays, scalars initialization 302 CALL wrk_alloc(jpi , jpj , ze1, ze2 ) 303 CALL wrk_alloc(jpi , jpj , jpk, ze3 ) 304 CALL wrk_alloc(jpi_crs, jpj_crs, zcfield2d_1, zcfield2d_2 ) 305 CALL wrk_alloc(jpi_crs, jpj_crs, jpk, zcfield3d_1, zcfield3d_2 ) 306 307 ze1(:,:) = 1.0 308 ze2(:,:) = 1.0 309 ze3(:,:,:) = 1.0 310 zcfield2d_1(:,:) = 0.0 311 zcfield2d_2(:,:) = 0.0 312 zcfield3d_1(:,:,:) = 0.0 313 zcfield3d_2(:,:,:) = 0.0 314 315 ijpk = jpk 316 317 ! Control of arguments 318 ze1(:,:) = p_e1(:,:) 319 ze2(:,:) = p_e2(:,:) 320 321 IF ( PRESENT(p_cfield2d_1) ) p_cfield2d_1(:,:) = 0.0 322 IF ( PRESENT(p_cfield2d_2) ) p_cfield2d_2(:,:) = 0.0 323 IF ( PRESENT(p_cfield3d_1) ) p_cfield3d_1(:,:,:) = 0.0 324 IF ( PRESENT(p_cfield3d_2) ) p_cfield3d_2(:,:,:) = 0.0 325 326 IF ( PRESENT(p_fse3) ) ze3(:,:,:) = p_fse3(:,:,:) 327 328 329 DO jk = 1, ijpk 330 331 zcfield2d_1(:,:) = 0.0 ; zcfield2d_2(:,:) = 0.0 332 ! DO ji = 2, jpi_crsm1 333 DO ji = 2, nlei_crs - 1 334 ijie = mie_crs(ji) 335 ijis = mis_crs(ji) 336 337 ! DO jj = 1, jpj_crsm1 338 DO jj = njstart, njend 339 ijje = mje_crs(jj) 340 ijjs = mjs_crs(jj) 341 342 IF ( cd_op == 'SUM' ) THEN 343 344 IF ( cd_type == 'W' ) THEN 345 346 ! Surface area of top of grid cell, e1e2 347 DO jii = ijis, ijie 348 DO jjj = ijjs, ijje 349 zcfield2d_1(ji,jj) = zcfield2d_1(ji,jj) + ( ze1(jii,jjj) * ze2(jii,jjj) ) 350 ENDDO 351 ENDDO 352 353 ! Surface ocean fraction, e1e2 masked/e1e2 total 354 IF ( zcfield2d_1(ji,jj) /= 0 ) THEN 355 DO jii = ijis, ijie 356 DO jjj = ijjs, ijje 357 zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) + ( ze1(jii,jjj) & 358 & * ze2(jii,jjj) & 359 & * p_pmask(jii,jjj,jk) ) 360 ENDDO 361 ENDDO 362 zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) / zcfield2d_1(ji,jj) 363 ENDIF 364 365 ELSE 366 SELECT CASE ( cd_type ) 367 368 CASE ( 'T' ) 369 IF ( nn_factx == 3 ) THEN 370 ! Calculate e1 scale factor or if present ze3, unmasked surface area 371 IF (jj == 1) THEN 372 DO jii = ijis, ijie 373 zcfield2d_1(ji,jj) = zcfield2d_1(ji,jj) + ( ze1(jii,ijje) * ze3(jii,ijje-1,jk) ) 374 ENDDO 375 ELSE 376 DO jii = ijis, ijie 377 zcfield2d_1(ji,jj) = zcfield2d_1(ji,jj) + ( ze1(jii,ijje-1) * ze3(jii,ijje-1,jk) ) 378 ENDDO 379 ENDIF 380 381 ! Calculate e2 scale factor 382 DO jjj = ijjs, ijje 383 zcfield2d_2(ji,jj) = zcfield2d_2(ji,jj) + ( ze2(ijie-1,jjj) * ze3(ijie-1,jjj,jk) ) 384 ENDDO 385 ENDIF 386 387 CASE ( 'U' ) 388 IF ( nn_factx == 3 ) THEN 389 ! Calculate e1 scale factor or if present ze3, unmasked surface area 390 IF (jj == 1) THEN 391 DO jii = ijis, ijie 392 zcfield2d_1(ji,jj) = zcfield2d_1(ji,jj) + ( ze1(jii+1,ijje) * ze3(jii+1,ijje-1,jk) ) 393 ENDDO 394 ELSE 395 DO jii = ijis, ijie 396 zcfield2d_1(ji,jj) = zcfield2d_1(ji,jj) + ( ze1(jii+1,ijje-1) * ze3(jii+1,ijje-1,jk) ) 397 ENDDO 398 ENDIF 399 ! Calculate e2 scale factor 400 DO jjj = ijjs, ijje 401 zcfield2d_2(ji,jj) = zcfield2d_2(ji,jj) + ( ze2(ijie,jjj) * ze3(ijie,jjj,jk) ) 402 ENDDO 403 ENDIF 404 405 CASE ( 'V' ) 406 IF ( nn_factx == 3 ) THEN 407 ! Calculate e1 scale factor or if present ze3, unmasked surface area 408 DO jii = ijis, ijie 409 zcfield2d_1(ji,jj) = zcfield2d_1(ji,jj) + ( ze1(jii,ijje) * ze3(jii,ijje,jk) ) 410 ENDDO 411 412 ! Calculate e2 scale factor 413 DO jjj = ijjs, ijje 414 zcfield2d_2(ji,jj) = zcfield2d_2(ji,jj) + ( ze2(ijie-1,jjj+1) * ze3(ijie-1,jjj+1,jk) ) 415 ENDDO 416 ENDIF 417 418 CASE ( 'F' ) 419 IF ( nn_factx == 3 ) THEN 420 ! Calculate e1 scale factor or if present ze3, unmasked surface area 421 DO jii = ijis, ijie 422 zcfield2d_1(ji,jj) = zcfield2d_1(ji,jj) + ( ze1(jii+1,ijje) * ze3(jii+1,ijje,jk) ) 423 ENDDO 424 425 ! Calculate e2 scale factor 426 DO jjj = ijjs, ijje 427 zcfield2d_2(ji,jj) = zcfield2d_2(ji,jj) + ( ze2(ijie,jjj+1) * ze3(ijie,jjj+1,jk) ) 428 ENDDO 429 ENDIF 430 END SELECT 431 432 433 434 IF ( PRESENT(p_cfield3d_1) ) THEN 435 436 IF ( cd_type == 'V' ) THEN 437 IF ( zcfield2d_1(ji,jj) /= 0 ) THEN ! e1 ocean length or e1e3 surface fraction 438 DO jii = ijis, ijie 439 zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) & 440 & + ( ze1(jii,ijje) * ze3(jii,ijje,jk) * p_pmask(jii,ijje,jk) ) 441 ENDDO 442 zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) / zcfield2d_1(ji,jj) 443 ENDIF 444 ENDIF 445 446 IF ( cd_type == 'U' ) THEN 447 IF ( zcfield2d_2(ji,jj) /= 0 ) THEN ! e2 ocean length or e2e3 surface fraction 448 DO jjj = ijjs, ijje 449 zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) & 450 & + ( ze2(ijie,jjj) * ze3(ijie,jjj,jk) * p_pmask(ijie,jjj,jk) ) 451 ENDDO 452 zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) / zcfield2d_2(ji,jj) 453 ENDIF 454 ENDIF 455 456 ENDIF 457 458 ENDIF 459 460 ENDIF 461 462 IF ( cd_op == 'POS' ) THEN !cc 463 464 IF ( nn_factx == 3 .AND. nn_facty == 3) THEN 465 466 SELECT CASE ( cd_type ) 467 468 CASE ( 'T' ) 469 470 IF ((jj == 1) .AND. (ji == 1)) THEN 471 ! Calculate e1 scale factor or if present ze3, unmasked surface area 472 zcfield2d_1(ji,jj) = ( ze1(ijie,ijje ) * ze3(ijie,ijje,jk) ) * nn_factx 473 474 ! Calculate e2 scale factor 475 zcfield2d_2(ji,jj) = ( ze2(ijie,ijje ) * ze3(ijie,ijje,jk) ) * nn_facty 476 ELSEIF (jj == 1) THEN 477 ! Calculate e1 scale factor or if present ze3, unmasked surface area 478 zcfield2d_1(ji,jj) = ( ze1(ijie-1,ijje ) * ze3(ijie-1,ijje,jk) ) * nn_factx 479 480 ! Calculate e2 scale factor 481 zcfield2d_2(ji,jj) = ( ze2(ijie-1,ijje ) * ze3(ijie-1,ijje,jk) ) * nn_facty 482 ELSEIF (ji == 1) THEN 483 ! Calculate e1 scale factor or if present ze3, unmasked surface area 484 zcfield2d_1(ji,jj) = ( ze1(ijie,ijje-1) * ze3(ijie,ijje-1,jk) ) * nn_factx 485 486 ! Calculate e2 scale factor 487 zcfield2d_2(ji,jj) = ( ze2(ijie,ijje-1) * ze3(ijie,ijje-1,jk) ) * nn_facty 488 ELSE 489 ! Calculate e1 scale factor or if present ze3, unmasked surface area 490 zcfield2d_1(ji,jj) = ( ze1(ijie-1,ijje-1) * ze3(ijie-1,ijje-1,jk) ) * nn_factx 491 492 ! Calculate e2 scale factor 493 zcfield2d_2(ji,jj) = ( ze2(ijie-1,ijje-1) * ze3(ijie-1,ijje-1,jk) ) * nn_facty 494 ENDIF 495 496 CASE ( 'U' ) 497 IF (jj == 1) THEN 498 ! Calculate e1 scale factor or if present ze3, unmasked surface area 499 zcfield2d_1(ji,jj) = ( ze1(ijie ,ijje ) * ze3(ijie ,ijje,jk) ) * nn_factx 500 501 ! Calculate e2 scale factor 502 zcfield2d_2(ji,jj) = ( ze2(ijie ,ijje ) * ze3(ijie ,ijje,jk) ) * nn_facty 503 ELSE 504 ! Calculate e1 scale factor or if present ze3, unmasked surface area 505 zcfield2d_1(ji,jj) = ( ze1(ijie ,ijje-1) * ze3(ijie ,ijje-1,jk) ) * nn_factx 506 507 ! Calculate e2 scale factor 508 zcfield2d_2(ji,jj) = ( ze2(ijie ,ijje-1) * ze3(ijie ,ijje-1,jk) ) * nn_facty 509 ENDIF 510 511 CASE ( 'V' ) 512 IF (ji == 1) THEN 513 ! Calculate e1 scale factor or if present ze3, unmasked surface area 514 zcfield2d_1(ji,jj) = ( ze1(ijie,ijje ) * ze3(ijie,ijje ,jk) ) * nn_factx 515 516 ! Calculate e2 scale factor 517 zcfield2d_2(ji,jj) = ( ze2(ijie,ijje ) * ze3(ijie,ijje ,jk) ) * nn_facty 518 ELSE 519 ! Calculate e1 scale factor or if present ze3, unmasked surface area 520 zcfield2d_1(ji,jj) = ( ze1(ijie-1,ijje ) * ze3(ijie-1,ijje ,jk) ) * nn_factx 521 522 ! Calculate e2 scale factor 523 zcfield2d_2(ji,jj) = ( ze2(ijie-1,ijje ) * ze3(ijie-1,ijje ,jk) ) * nn_facty 524 ENDIF 525 526 CASE ( 'F' ) 527 ! Calculate e1 scale factor or if present ze3, unmasked surface area 528 zcfield2d_1(ji,jj) = ( ze1(ijie ,ijje ) * ze3(ijie ,ijje ,jk) ) * nn_factx 529 530 ! Calculate e2 scale factor 531 zcfield2d_2(ji,jj) = ( ze2(ijie ,ijje ) * ze3(ijie ,ijje ,jk) ) * nn_facty 532 533 END SELECT 534 ENDIF 535 ENDIF !cc 536 537 538 IF ( cd_op == 'WGT' ) THEN 539 540 zdAm = 0.0 541 542 IF ( cd_type == 'V' ) THEN 543 ! 544 DO jii = ijis, ijie 545 zdAm = zdAm + ( ze1(jii,ijje) * ze3(jii,ijje,jk) * p_pmask(jii,ijje,jk) ) 546 ENDDO 547 IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm 548 549 ELSEIF ( cd_type == 'U') THEN 550 DO jjj = ijjs, ijje 551 zdAm = zdAm + ( ze2(ijie,jjj) * ze3(ijie,jjj,jk) * p_pmask(ijie,jjj,jk) ) 552 ENDDO 553 IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm 554 555 ELSEIF ( cd_type == 'W' ) THEN 556 DO jii = ijis, ijie 557 DO jjj = ijjs, ijje 558 zdAm = zdAm + ( ze1(jii,jjj) * ze2(jii,jjj) * p_pmask(jii,jjj,jk) ) 559 ENDDO 560 ENDDO 561 IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm 562 563 ELSEIF ( cd_type == 'T' ) THEN 564 DO jii = ijis, ijie 565 DO jjj = ijjs, ijje 566 zdAm = zdAm + ( ze1(jii,jjj) * ze2(jii,jjj) * ze3(jii,jjj,jk) * p_pmask(jii,jjj,jk) ) 567 ENDDO 568 ENDDO 569 IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm 570 571 ELSE 572 573 ! jes. Add a stop? 574 575 ENDIF 576 577 ENDIF 578 579 IF ( cd_op == 'VOL' ) THEN 580 581 zdAm = 0.0 582 583 IF ( cd_type == 'W' .OR. cd_type == 'T' ) THEN 584 585 DO jii = ijis, ijie 586 DO jjj = ijjs, ijje 587 zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) + ( ze1(jii,jjj) * ze2(jii,jjj) * ze3(jii,jjj,jk) ) 588 zdAm = zdAm + ( ze1(jii,jjj) * ze2(jii,jjj) * ze3(jii,jjj,jk) * p_pmask(jii,jjj,jk) ) 589 ENDDO 590 ENDDO 591 IF ( zcfield3d_1(ji,jj,jk) /= 0 ) zcfield3d_2(ji,jj,jk) = zdAm / zcfield3d_1(ji,jj,jk) 592 593 ELSE 594 ! jes. add a stop? 595 ENDIF 596 597 ENDIF 598 599 ENDDO 600 ENDDO 601 602 ENDDO 603 604 ! Retroactively add back the boundary halo cells. 605 606 IF( nperio /= 0 ) THEN 607 608 ! Take care of the 2D arrays 609 IF ( cd_op == 'SUM' .OR. cd_op == 'POS') THEN 610 IF ( PRESENT(p_cfield2d_1) ) THEN 611 p_cfield2d_1(:,:) = zcfield2d_1(:,:) 612 CALL crs_lbc_lnk( cd_type,1.0,pt2d=p_cfield2d_1 ) 613 614 ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 615 p_cfield2d_1(:,1) = zcfield2d_1(:,1) !cc 616 ! Fill i=1, i=jpi at j=1 617 p_cfield2d_1(1,1) = p_cfield2d_1(jpi_crsm1,1) 618 p_cfield2d_1(jpi_crs,1) = p_cfield2d_1(2,1) 619 620 !cc p_cfield2d_1(1,jpj_crs-1) = p_cfield2d_1(3,jpj_crs-1) 621 622 ! Fill upper-right corner i=1, j=jpj_crs 623 !cc IF ( nperio == 4 ) THEN on écrase les valeurs limites calculées dans crs_lbc_lnk 624 !cc p_cfield2d_1(1,jpj_crs) = p_cfield2d_1(jpi_crsm1,jpj_crs-2) 625 !cc ELSEIF ( nperio == 6 ) THEN 626 !cc p_cfield2d_1(1,jpj_crs) = p_cfield2d_1(jpi_crs,jpj_crsm1) 627 !cc ENDIF 628 629 ENDIF 630 IF ( PRESENT(p_cfield2d_2) ) THEN 631 p_cfield2d_2(:,:) = zcfield2d_2(:,:) 632 CALL crs_lbc_lnk( cd_type,1.0,pt2d=p_cfield2d_2 ) 633 634 ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 635 p_cfield2d_2(:,1) = zcfield2d_2(:,1) 636 637 ! Fill i=1, i=jpi at j=1 638 p_cfield2d_2(1,1) = p_cfield2d_2(jpi_crsm1,1) 639 p_cfield2d_2(jpi_crs,1) = p_cfield2d_2(2,1) 640 IF ( cd_op == 'SUM') THEN 641 DO jii = 1 , jpiglo_crs 642 p_cfield2d_2(jii,1) = p_cfield2d_2(jii,1) * 3 643 ENDDO 644 ENDIF 645 ! Fill upper-right corner i=1, j=jpj_crs 646 !cc IF ( nperio == 4 ) THEN 647 !cc p_cfield2d_2(1,jpj_crs) = p_cfield2d_2(jpi_crsm1,jpj_crs-2) 648 !cc ELSEIF ( nperio == 6 ) THEN 649 !cc p_cfield2d_2(1,jpj_crs) = p_cfield2d_2(jpi_crs,jpj_crsm1) 650 !cc ENDIF 651 ENDIF 652 653 ELSE 654 655 CALL crs_lbc_lnk( cd_type,1.0,pt2d=zcfield2d_1 ) 656 IF ( PRESENT(p_cfield2d_1) ) p_cfield2d_1(:,:) = zcfield2d_1(:,:) 657 CALL crs_lbc_lnk( cd_type,1.0,pt2d=zcfield2d_2 ) 658 IF ( PRESENT(p_cfield2d_2) ) p_cfield2d_2(:,:) = zcfield2d_2(:,:) 659 660 ENDIF 661 662 ! Take care now of 3d arrays 663 IF ( cd_op == 'SUM' .OR. cd_op == 'VOL' .OR. cd_op == 'POS' ) THEN 664 CALL crs_lbc_lnk( cd_type,1.0,pt3d1=zcfield3d_1 ) 665 IF ( PRESENT(p_cfield3d_1) ) p_cfield3d_1(:,:,:) = zcfield3d_1(:,:,:) 666 CALL crs_lbc_lnk( cd_type,1.0,pt3d1=zcfield3d_2 ) 667 IF ( PRESENT(p_cfield3d_2) ) p_cfield3d_2(:,:,:) = zcfield3d_2(:,:,:) 668 ELSE 669 p_cfield3d_1(:,:,:) = zcfield3d_1(:,:,:) 670 CALL crs_lbc_lnk( cd_type,1.0,pt3d1=p_cfield3d_1 ) 671 672 ! Fill upper-right corner i=1, j=jpj_crs 673 IF ( nperio == 4 ) THEN 674 p_cfield3d_1(1,jpj_crs,:) = p_cfield3d_1(jpi_crsm1,jpj_crs-2,:) 675 ELSEIF ( nperio == 6 ) THEN 676 p_cfield3d_1(1,jpj_crs,:) = p_cfield3d_1(jpi_crs,jpj_crsm1,:) 677 ENDIF 678 679 ENDIF 680 681 ELSE 682 IF ( cd_op == 'SUM' .OR. cd_op == 'POS' ) THEN 683 IF ( PRESENT(p_cfield2d_1) ) THEN 684 p_cfield2d_1(:,:) = zcfield2d_1(:,:) 685 p_cfield2d_1( 1,:) = p_cfield2d_1( 2,:) ! all points 686 p_cfield2d_1(jpi_crs,:) = p_cfield2d_1(jpi_crsm1,:) 687 p_cfield2d_1( :,1) = p_cfield2d_1( :,2) 688 p_cfield2d_1(:,jpj_crs) = p_cfield2d_1(:,jpj_crsm1) 689 ENDIF 690 IF ( PRESENT(p_cfield2d_2) ) THEN 691 p_cfield2d_2(:,:) = zcfield2d_2(:,:) 692 p_cfield2d_2( 1,:) = p_cfield2d_2( 2,:) ! all points 693 p_cfield2d_2(jpi_crs,:) = p_cfield2d_2(jpi_crsm1,:) 694 p_cfield2d_2( :,1) = p_cfield2d_2( :,2) 695 p_cfield2d_2(:,jpj_crs) = p_cfield2d_2(:,jpj_crsm1) 696 ENDIF 697 ENDIF 698 699 IF ( PRESENT( p_cfield3d_1 ) ) THEN 700 p_cfield3d_1(:,:,:) = zcfield3d_1(:,:,:) 701 p_cfield3d_1( 1 ,:,:) = p_cfield3d_1( 2 ,:,:) ! all points 702 p_cfield3d_1(jpi_crs,:,:) = p_cfield3d_1(jpi_crsm1,:,:) 703 p_cfield3d_1( : ,1,:) = p_cfield3d_1( : ,2,:) 704 p_cfield3d_1(:,jpj_crs,:) = p_cfield3d_1(:,jpj_crsm1,:) 705 ENDIF 706 IF ( PRESENT( p_cfield3d_2 ) ) THEN 707 p_cfield3d_2(:,:,:) = zcfield3d_2(:,:,:) 708 p_cfield3d_2( 1 ,:,:) = p_cfield3d_2( 2 ,:,:) ! all points 709 p_cfield3d_2(jpi_crs,:,:) = p_cfield3d_2(jpi_crsm1,:,:) 710 p_cfield3d_2( : ,1,:) = p_cfield3d_2( : ,2,:) 711 p_cfield3d_2(:,jpj_crs,:) = p_cfield3d_2(:,jpj_crsm1,:) 712 ENDIF 713 ENDIF 714 715 CALL wrk_dealloc(jpi , jpj , ze1, ze2 ) 716 CALL wrk_dealloc(jpi , jpj , jpk, ze3 ) 717 CALL wrk_dealloc(jpi_crs, jpj_crs, zcfield2d_1, zcfield2d_2 ) 718 CALL wrk_dealloc(jpi_crs, jpj_crs, jpk, zcfield3d_1, zcfield3d_2 ) 719 720 END SUBROUTINE crsfun_wgt 721 722 723 SUBROUTINE crsfun_UV( p_e1_e2, cd_type, psgn, p_pmask, p_fse3, p_pfield, p_surf_crs, p_cfield3d ) 724 !!---------------------------------------------------------------- 725 !! *** SUBROUTINE crsfun_UV *** 726 !! ** Purpose : Average, area-weighted, of U or V on the east and north faces 727 !! 728 !! ** Method : The U and V velocities (3D) are determined as the area-weighted averages 729 !! on the east and north faces, respectively, 730 !! of the parent grid subset comprising the coarse grid box. 731 !! In the case of the V and F grid, the last jrow minus 1 is spurious. 732 !! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f) 733 !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) 734 !! psgn = sign change over north fold (See lbclnk.F90) 735 !! p_pmask = parent grid mask (T,U,V,F) for scale factors; 736 !! for velocities (U or V) 737 !! p_fse3 = parent grid vertical level thickness (fse3u or fse3v) 738 !! p_pfield = U or V on the parent grid 739 !! p_surf_crs = (Optional) Coarse grid weight for averaging 740 !! ** Outputs : p_cfield3d = 3D field on coarse grid 741 !! 742 !! History. 29 May. completed draft. 743 !! 4 Jun. Revision for WGT 744 !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. 745 !!---------------------------------------------------------------- 746 !! 747 !! Arguments 748 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_e1_e2 ! Parent grid U,V scale factors (e1 or e2) 749 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V 750 REAL(wp), INTENT(in) :: psgn ! sign change option across north fold 751 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_pmask ! Parent grid U,V mask 752 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fse3 ! Parent grid vertical level thickness (fse3u, fse3v) 753 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_pfield ! U or V on parent grid 754 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator 755 756 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_cfield3d ! Coarse grid box 3D quantity 757 758 !! Local variables 759 INTEGER :: ji, jj, jk , jii, jjj ! dummy loop indices 760 INTEGER :: ijie, ijis, ijje, ijjs 761 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurfcrs 762 763 !!---------------------------------------------------------------- 764 765 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zsurfcrs ) 766 zsurfcrs(:,:,:) = 1.0 767 IF ( PRESENT(p_surf_crs) ) THEN 768 WHERE ( p_surf_crs /= 0 ) zsurfcrs(:,:,:) = 1.0/p_surf_crs(:,:,:) 769 ENDIF 770 771 DO jk = 1, jpk 772 773 DO ji = 2, nlei_crs - 1 774 ijie = mie_crs(ji) 775 ijis = mis_crs(ji) 776 777 DO jj = njstart, njend 778 ijje = mje_crs(jj) 779 ijjs = mjs_crs(jj) 780 781 IF ( cd_type == 'V' ) THEN 782 783 DO jii = ijis, ijie 784 p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) & 785 & + ( p_pfield(jii,ijje,jk) * p_e1_e2(jii,ijje) * p_fse3(jii,ijje,jk) * p_pmask(jii,ijje,jk) ) 786 ENDDO 787 p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) * zsurfcrs(ji,jj,jk) 788 789 ELSEIF ( cd_type == 'U') THEN 790 791 DO jjj = ijjs, ijje 792 p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) & 793 & + ( p_pfield(ijie,jjj,jk) * p_e1_e2(ijie,jjj) * p_fse3(ijie,jjj,jk) * p_pmask(ijie,jjj,jk) ) 794 ENDDO 795 p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) * zsurfcrs(ji,jj,jk) 796 797 ENDIF 798 799 ENDDO 800 ENDDO 801 ENDDO 802 803 ! Retroactively add back the boundary halo cells. 804 805 IF( nperio /= 0 ) THEN 806 CALL crs_lbc_lnk( cd_type,psgn,pt3d1=p_cfield3d ) 807 ELSE 808 p_cfield3d( 1 ,:,:) = p_cfield3d( 2 ,:,:) ! all points 809 p_cfield3d(jpi_crs,:,:) = p_cfield3d(jpi_crsm1,:,:) 810 p_cfield3d( : ,1,:) = p_cfield3d( : ,2,:) 811 p_cfield3d(:,jpj_crs,:) = p_cfield3d(:,jpj_crsm1,:) 812 ENDIF 813 814 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zsurfcrs ) 815 816 END SUBROUTINE crsfun_UV 817 818 SUBROUTINE crsfun_TW( p_e1e2t, cd_type, cd_op, p_cmask, p_ptmask, psgn, p_pfield2d, p_pfield3d_1, p_pfield3d_2, & 819 & p_cfield2d, p_cfield3d) 820 !!---------------------------------------------------------------- 821 !! *** SUBROUTINE crsfun_TW *** 822 !! ** Purpose : Five applications. 823 !! 1) Maximum surface quantity 824 !! - Vertical scale factors (fse3t or fse3w) 825 !! max thickness of the parent grid for coarse grid scale factors. 826 !! - or diffusion test 827 !! 2) Area-weighted mean quantity: w, or other 3D or 2D quantity 828 !! 3) Volume-weighted mean quantity: tracer 829 !! 4) Minimum surface quantity (diffusion test) 830 !! 5) Area- or Volume- weighted sum. 831 !! ** Method : 1) - cd_op = 'MAX'. Determines the max vertical thickness of grid boxes 832 !! including partial steps for at the bottom 833 !! for the coarsened grid, where within the subset of 834 !! the parent grid cells the maximum thickness is taken. 835 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 836 !! Where, normally p_pfield3d_1 is e3t. 837 !! - cd_op = 'MAX'. May also be used for say, determining the maximum value of Kz, 838 !! thus p_pfield3d_1 is set to the 3D field, Kz. 839 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 840 !! 2) - cd_op = 'ARE'. Calculate the area-weighted average (surface e1t*e2t) 841 !! of vertical velocity, w. 842 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 843 !! - cd_op = 'ARE'. Calculate area-weighted average of a 2D quantity (e.g. emp) 844 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield2d 845 !! 3) - cd_op = 'VOL'. Calculate the ocean volume (e1e2t*[fse3t|fse3w]) 846 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 847 !! - cd_op = 'VOL'. Calculate volume-weighted average (volume e1t*e2t*fse3t) of a quantity. 848 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1, p_pfield3d_2 849 !! 4) - cd_op = 'MIN'. Calculate the minimum value on surface e1t*e2t for 3D variables 850 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 851 !! 5) - cd_op = 'SUM'. Calculate a dimesionally-weighted sum. This could be area-weighted 852 !! or volume-weighted sum. 853 !! ** Inputs : p_e1e2t = parent grid top face surface area, e1t*e2t 854 !! cd_type = grid type T, W (U, V, F) 855 !! cd_op = MAX, ARE, VOL, MIN, SUM 856 !! p_cmask = coarse grid mask 857 !! p_ptmask = parent grid tmask 858 !! psgn = (Optional) sign for lbc_lnk 859 !! p_pfield2d = (Optional) 2D field on parent grid 860 !! p_pfield3d_1 = (Optional) parent grid fse3t or fse3w 861 !! p_pfield3d_2 = (Optional) 3D field on parent grid 862 !! ** Outputs : p_cfield2d = (Optional) 2D field on coarse grid 863 !! p_cfield3d = (Optional) 3D field on coarse grid 864 !! 865 !! 866 !! History. 30 May. Editing. To decide later: Keep all functionality or separate out the mean function. 867 !! 7 Jun TODO. Need to fix up the parent grid mask to optional like crsfun_UV... 868 !!---------------------------------------------------------------- 869 !! 870 !! Arguments 871 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_e1e2t ! Parent grid T surface (e1*e2) 872 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) 873 CHARACTER(len=3), INTENT(in) :: cd_op ! operation max, min, area-average, volume-average 874 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_cmask ! Coarse grid T mask 875 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_ptmask ! Parent grid T mask 876 REAL(wp), OPTIONAL, INTENT(in) :: psgn ! sign for lbc_lnk 877 REAL(wp), DIMENSION(jpi,jpj), OPTIONAL, INTENT(in) :: p_pfield2d ! 2D quantity on parent grid, e.g. ssh 878 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(in) :: p_pfield3d_1 ! Normally parent grid vertical level thickness 879 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(in) :: p_pfield3d_2 ! 3D tracer or W on parent grid 880 881 REAL(wp), DIMENSION(jpi_crs,jpj_crs), OPTIONAL, INTENT(out):: p_cfield2d ! Coarse grid box east or north face quantity 882 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), OPTIONAL, INTENT(out):: p_cfield3d ! Coarse grid box east or north face quantity 883 884 !! Local variables 885 INTEGER :: ji, jj, jk ! dummy loop indices 886 INTEGER :: ijie,ijis,ijje,ijjs,ijpk,jii,jjj 887 INTEGER, DIMENSION(3) :: idims 888 REAL(wp), POINTER, DIMENSION(:,:) :: ze1e2, zpfield2d, zcfield2d 889 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3, zpfield3d, zcfield3d, zcmask, zpmask 890 REAL(wp) :: zdAm, zsgn 891 !!---------------------------------------------------------------- 892 ! Initialize 893 894 CALL wrk_alloc(jpi , jpj , ze1e2, zpfield2d ) 895 CALL wrk_alloc(jpi , jpj , jpk, ze3 , zpfield3d, zpmask ) 896 CALL wrk_alloc(jpi_crs, jpj_crs, zcfield2d ) 897 CALL wrk_alloc(jpi_crs, jpj_crs, jpk, zcfield3d, zcmask ) 898 899 900 ! Arrays, scalars initialization 901 zpfield2d(:,:) = 0.0 902 zpfield3d(:,:,:) = 0.0 903 zcfield2d(:,:) = 0.0 904 zcfield3d(:,:,:) = 0.0 905 zpmask(:,:,:) = 1.0 906 idims(:) = 1 907 908 zcmask(:,:,:) = p_cmask(:,:,:) 909 zpmask(:,:,:) = p_ptmask(:,:,:) 910 911 ijpk = jpk 912 913 914 ! Control of optional arguments 321 !! ** Purpose : Save the parent grid information & Switch to coarse grid domain 322 !!--------------------------------------------------------------------- 323 324 915 325 ! 916 IF ( PRESENT(psgn) ) THEN 917 zsgn = psgn 918 ELSE 919 zsgn = 1.0 920 ENDIF 326 ! Switch to coarse grid domain 327 jpi = jpi_crs 328 jpj = jpj_crs 329 jpim1 = jpi_crsm1 330 jpjm1 = jpj_crsm1 331 nperio = nperio_crs 332 333 npolj = npolj_crs 334 jpiglo = jpiglo_crs 335 jpjglo = jpjglo_crs 336 337 338 nlci = nlci_crs 339 nlcj = nlcj_crs 340 nldi = nldi_crs 341 nlei = nlei_crs 342 nlej = nlej_crs 343 nldj = nldj_crs 344 nimpp = nimpp_crs 345 njmpp = njmpp_crs 346 347 nlcit(:) = nlcit_crs(:) 348 nldit(:) = nldit_crs(:) 349 nleit(:) = nleit_crs(:) 350 nimppt(:) = nimppt_crs(:) 351 nlcjt(:) = nlcjt_crs(:) 352 nldjt(:) = nldjt_crs(:) 353 nlejt(:) = nlejt_crs(:) 354 njmppt(:) = njmppt_crs(:) 355 356 921 357 ! 922 IF ( TRIM(cd_op) == 'MAX' ) THEN 923 ! Find the maximum thickness in each parent grid subset 924 IF ( PRESENT(p_pfield3d_1) ) THEN 925 zpfield3d(:,:,:) = p_pfield3d_1(:,:,:) 926 ze3(:,:,:) = 0.0 927 ze1e2(:,:) = 0.0 928 ELSE 929 WRITE(numout,*) 'crsfun_TW. MAX only 3D arrays supported' 930 ENDIF 931 ELSEIF ( TRIM(cd_op) == 'VOL' ) THEN 932 IF ( PRESENT(p_pfield3d_1) ) THEN 933 ze3(:,:,:) = p_pfield3d_1(:,:,:) 934 IF ( PRESENT(p_pfield3d_2) ) THEN 935 ! ! Prep to calculate a volume-averaged mean 936 zpfield3d(:,:,:) = p_pfield3d_2(:,:,:) 937 ze1e2(:,:) = p_e1e2t(:,:) 938 ELSE 939 WRITE(numout,*) 'crsfun_TW. WARNING. Supply both e3t and the field for volume-averaged field' 940 ENDIF 941 ELSE 942 WRITE(numout,*) 'crsfun_TW. VOL only 3D arrays supported' 943 ENDIF 944 ELSEIF ( TRIM(cd_op) == 'ARE' ) THEN 945 ze1e2(:,:) = p_e1e2t(:,:) 946 ze3(:,:,:) = 1.0 947 IF ( PRESENT(p_pfield3d_2) ) THEN 948 ! Prep to do the area-weighted average of (3D) W 949 zpfield3d(:,:,:) = p_pfield3d_2(:,:,:) 950 ELSEIF ( PRESENT(p_pfield2d) ) THEN 951 ! Prep to do the area-weighted average of some 2D quantity 952 zpfield2d(:,:) = p_pfield2d(:,:) 953 ijpk=1 954 ENDIF 955 ELSEIF ( TRIM(cd_op) == 'MIN' ) THEN 956 IF ( PRESENT(p_pfield3d_1) ) THEN 957 ! Prep to do get the minimum diffusion on the top face 958 zpfield3d(:,:,:) = p_pfield3d_1(:,:,:) 959 ze3(:,:,:) = 0.0 960 ze1e2(:,:) = 0.0 961 ELSE 962 WRITE(numout,*) 'crsfun_TW. MIN Only 3D arrays supported' 963 ENDIF 964 ELSEIF ( TRIM(cd_op) == 'SUM' ) THEN 965 ze1e2(:,:) = p_e1e2t(:,:) 966 zpmask(:,:,:) = p_ptmask(:,:,:) 967 ze3(:,:,:) = 1.0 968 IF ( PRESENT(p_pfield3d_1) ) THEN 969 IF ( PRESENT(p_pfield3d_2) ) THEN 970 ! ! Prep to calculate a volume-weighted sum 971 zpfield3d(:,:,:) = p_pfield3d_2(:,:,:) 972 ze3(:,:,:) = p_pfield3d_1(:,:,:) 973 ELSE 974 ! Prep to do the area-weighted sum of (3D) W 975 zpfield3d(:,:,:) = p_pfield3d_1(:,:,:) 976 ENDIF 977 ELSEIF ( PRESENT(p_pfield2d) ) THEN 978 ! Prep to do the area-weighted sum of some 2D quantity 979 zpfield2d(:,:) = p_pfield2d(:,:) 980 ijpk=1 981 ENDIF 982 ELSE 983 WRITE(numout,*) 'crsfun_TW. valid cd_op are MAX, MIN, ARE, VOL, SUM' 984 ENDIF 985 986 ! Determine output 987 DO jk = 1, ijpk 988 989 IF ( ijpk == jpk ) zpfield2d(:,:) = zpfield3d(:,:,jk) 990 zcfield2d(:,:) = 0.0 991 992 DO ji = 2, nlei_crs - 1 993 ijie = mie_crs(ji) 994 ijis = mis_crs(ji) 995 996 DO jj = njstart, njend 997 ! DO jj = 1, jpj_crsm1 998 ijje = mje_crs(jj) 999 ijjs = mjs_crs(jj) 1000 1001 ! First determine weighted sums 1002 IF ( TRIM(cd_op) == 'SUM' .OR. TRIM(cd_op) == 'ARE' .OR. TRIM(cd_op) == 'VOL' ) THEN 1003 ! Area- or volume- weighted sum 1004 ! Accumulate to sum in parent grid subset 1005 DO jii = ijis, ijie 1006 DO jjj = ijjs, ijje 1007 zcfield2d(ji,jj) = zcfield2d(ji,jj) & 1008 & + ( zpfield2d(jii,jjj) & 1009 & * ze1e2(jii,jjj) & 1010 & * ze3(jii,jjj,jk) & 1011 & * zpmask(jii,jjj,jk) ) 1012 1013 ENDDO 1014 ENDDO 1015 1016 ENDIF 1017 1018 ! Calculate weighted average if desired 1019 IF ( TRIM(cd_op) == 'ARE' .OR. TRIM(cd_op) == 'VOL' ) THEN 1020 1021 ! Area- or volume- weighted mean 1022 ! Sum first parent grid subset 1023 zdAm = 0.0 1024 DO jii = ijis, ijie 1025 DO jjj = ijjs, ijje 1026 zdAm = zdAm + ( ze1e2(jii,jjj) & 1027 & * ze3(jii,jjj,jk) & 1028 & * zpmask(jii,jjj,jk) ) 1029 ENDDO 1030 ENDDO 1031 1032 IF ( zdAm /= 0 ) zcfield2d(ji,jj) = zcfield2d(ji,jj) / zdAm 1033 1034 ENDIF 1035 1036 1037 IF ( TRIM(cd_op) == 'MAX' ) THEN 1038 ! Find max in parent grid subset 1039 DO jii = ijis, ijie 1040 DO jjj = ijjs, ijje 1041 zcfield2d(ji,jj) = MAX( zcfield2d(ji,jj), zpfield3d(jii,jjj,jk)*zpmask(jii,jjj,jk) ) 1042 ENDDO 1043 ENDDO 1044 ENDIF 1045 1046 IF ( TRIM(cd_op) == 'MIN' ) THEN 1047 ! Find min in parent grid subset 1048 DO jii = ijis, ijie 1049 DO jjj = ijjs, ijje 1050 IF ( zpmask(jii,jjj,jk) == 1 ) THEN 1051 zcfield2d(ji,jj) = MIN( zcfield2d(ji,jj), zpfield3d(jii,jjj,jk) ) 1052 ENDIF 1053 ENDDO 1054 ENDDO 1055 ENDIF 1056 1057 ENDDO 1058 ENDDO 1059 1060 IF ( ijpk == 1 ) THEN 1061 IF ( PRESENT(p_cfield2d) ) p_cfield2d(:,:) = zcfield2d(:,:) * zcmask(:,:,jk) 1062 ELSE 1063 IF ( PRESENT(p_cfield3d) ) p_cfield3d(:,:,jk) = zcfield2d(:,:) * zcmask(:,:,jk) 1064 ENDIF 1065 1066 ENDDO 1067 1068 1069 ! Retroactively add back the boundary halo cells. 1070 1071 IF( nperio /= 0 ) THEN 1072 IF ( ijpk == 1 ) THEN 1073 IF ( PRESENT(p_cfield2d) ) CALL crs_lbc_lnk( cd_type,zsgn,pt2d=p_cfield2d ) 1074 ELSE 1075 IF ( PRESENT(p_cfield3d) ) THEN 1076 CALL crs_lbc_lnk( cd_type,zsgn,pt3d1=p_cfield3d ) 1077 ENDIF 1078 ENDIF 1079 ELSE 1080 IF ( ijpk == 1 ) THEN 1081 IF ( PRESENT(p_cfield2d) ) THEN 1082 p_cfield2d( 1,:) = p_cfield2d( 2,:) ! all points 1083 p_cfield2d(jpi_crs,:) = p_cfield2d(jpi_crsm1,:) 1084 p_cfield2d( :,1) = p_cfield2d( :,2) 1085 p_cfield2d(:,jpj_crs) = p_cfield2d(:,jpj_crsm1) 1086 ENDIF 1087 ELSE 1088 IF ( PRESENT(p_cfield3d) ) THEN 1089 p_cfield3d( 1 ,:,:) = p_cfield3d( 2 ,:,:) ! all points 1090 p_cfield3d(jpi_crs,:,:) = p_cfield3d(jpi_crsm1,:,:) 1091 p_cfield3d( : ,1,:) = p_cfield3d( : ,2,:) 1092 p_cfield3d(:,jpj_crs,:) = p_cfield3d(:,jpj_crsm1,:) 1093 ENDIF 1094 ENDIF 1095 ENDIF 1096 1097 CALL wrk_dealloc(jpi , jpj , ze1e2, zpfield2d ) 1098 CALL wrk_dealloc(jpi , jpj , jpk, ze3 , zpfield3d, zpmask ) 1099 CALL wrk_dealloc(jpi_crs, jpj_crs, zcfield2d ) 1100 CALL wrk_dealloc(jpi_crs, jpj_crs, jpk, zcfield3d, zcmask ) 1101 1102 1103 END SUBROUTINE crsfun_TW 1104 1105 SUBROUTINE crs_e3_max( p_e3, cd_type, p_mask, p_e3_crs) 1106 !!---------------------------------------------------------------- 1107 !! *** SUBROUTINE crsfun_TW *** 1108 !! ** Purpose : Five applications. 1109 !! 1) Maximum surface quantity 1110 !! - Vertical scale factors (fse3t or fse3w) 1111 !! max thickness of the parent grid for coarse grid scale factors. 1112 !! - or diffusion test 1113 !! 2) Area-weighted mean quantity: w, or other 3D or 2D quantity 1114 !! 3) Volume-weighted mean quantity: tracer 1115 !! 4) Minimum surface quantity (diffusion test) 1116 !! 5) Area- or Volume- weighted sum. 1117 !! ** Method : 1) - cd_op = 'MAX'. Determines the max vertical thickness of grid boxes 1118 !! including partial steps for at the bottom 1119 !! for the coarsened grid, where within the subset of 1120 !! the parent grid cells the maximum thickness is taken. 1121 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1122 !! Where, normally p_pfield3d_1 is e3t. 1123 !! - cd_op = 'MAX'. May also be used for say, determining the maximum value of Kz, 1124 !! thus p_pfield3d_1 is set to the 3D field, Kz. 1125 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1126 !! 2) - cd_op = 'ARE'. Calculate the area-weighted average (surface e1t*e2t) 1127 !! of vertical velocity, w. 1128 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1129 !! - cd_op = 'ARE'. Calculate area-weighted average of a 2D quantity (e.g. emp) 1130 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield2d 1131 !! 3) - cd_op = 'VOL'. Calculate the ocean volume (e1e2t*[fse3t|fse3w]) 1132 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1133 !! - cd_op = 'VOL'. Calculate volume-weighted average (volume e1t*e2t*fse3t) of a quantity. 1134 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1, p_pfield3d_2 1135 !! 4) - cd_op = 'MIN'. Calculate the minimum value on surface e1t*e2t for 3D variables 1136 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1137 !! 5) - cd_op = 'SUM'. Calculate a dimesionally-weighted sum. This could be area-weighted 1138 !! or volume-weighted sum. 1139 !! ** Inputs : p_e1e2t = parent grid top face surface area, e1t*e2t 1140 !! cd_type = grid type T, W (U, V, F) 1141 !! cd_op = MAX, ARE, VOL, MIN, SUM 1142 !! p_cmask = coarse grid mask 1143 !! p_ptmask = parent grid tmask 1144 !! psgn = (Optional) sign for lbc_lnk 1145 !! p_pfield2d = (Optional) 2D field on parent grid 1146 !! p_pfield3d_1 = (Optional) parent grid fse3t or fse3w 1147 !! p_pfield3d_2 = (Optional) 3D field on parent grid 1148 !! ** Outputs : p_cfield2d = (Optional) 2D field on coarse grid 1149 !! p_cfield3d = (Optional) 3D field on coarse grid 1150 !! 1151 !! 1152 !! History. 30 May. Editing. To decide later: Keep all functionality or separate out the mean function. 1153 !! 7 Jun TODO. Need to fix up the parent grid mask to optional like crsfun_UV... 1154 !!---------------------------------------------------------------- 1155 !! 1156 !! Arguments 1157 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) 1158 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask 1159 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid 1160 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout):: p_e3_crs ! Coarse grid box east or north face quantity 1161 1162 !! Local variables 1163 INTEGER :: ji, jj, jk ! dummy loop indices 1164 INTEGER :: ijie,ijis,ijje,ijjs,jii,jjj 1165 !!---------------------------------------------------------------- 1166 ! Initialize 1167 1168 SELECT CASE ( cd_type ) 1169 1170 CASE ('T') 1171 1172 DO jk = 1 , jpk 1173 1174 DO ji = 2, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1175 ijie = mie_crs(ji) 1176 ijis = mis_crs(ji) 1177 1178 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1179 ijje = mje_crs(jj) 1180 ijjs = mjs_crs(jj) 1181 1182 DO jii = ijis, ijie 1183 DO jjj = ijjs, ijje 1184 p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk) ) 1185 ENDDO 1186 ENDDO 1187 ENDDO 1188 ENDDO 1189 ENDDO 1190 1191 CASE ('W') 1192 1193 DO jk = 2 , jpk 1194 1195 DO ji = 2, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1196 ijie = mie_crs(ji) 1197 ijis = mis_crs(ji) 1198 1199 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1200 ijje = mje_crs(jj) 1201 ijjs = mjs_crs(jj) 1202 1203 DO jii = ijis, ijie 1204 DO jjj = ijjs, ijje 1205 p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk-1) ) 1206 ENDDO 1207 ENDDO 1208 ENDDO 1209 ENDDO 1210 ENDDO 1211 1212 jk = 1 ! cas particulier car zpmask(jii,jjj,0) n'existe pas 1213 1214 DO ji = 2, nlei_crs - 1 1215 ijie = mie_crs(ji) 1216 ijis = mis_crs(ji) 1217 1218 DO jj = njstart, njend 1219 ijje = mje_crs(jj) 1220 ijjs = mjs_crs(jj) 1221 1222 DO jii = ijis, ijie 1223 DO jjj = ijjs, ijje 1224 p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk) ) 1225 ENDDO 1226 ENDDO 1227 ENDDO 1228 ENDDO 1229 1230 END SELECT 1231 1232 CALL crs_lbc_lnk( cd_type, 1.0, pt3d1=p_e3_crs ) 1233 1234 ! lbcnlk met la ligne jpj = 1 a 0 donc il faut la remettre en ne pas oubliant le cyclique est-ouest 1235 1236 p_e3_crs( 1 ,1,:) = p_e3_crs(jpi_crsm1,1,:) 1237 p_e3_crs(jpi_crs,1,:) = p_e3_crs( 2 ,1,:) 1238 1239 WRITE(numout,*) 'crs_e3_max : end of subroutine ' 1240 1241 1242 END SUBROUTINE crs_e3_max 1243 1244 1245 SUBROUTINE crs_surf(p_e1, p_e2 ,p_e3, cd_type, p_mask, surf_crs, surf_msk_crs) 1246 !!---------------------------------------------------------------- 1247 !! *** SUBROUTINE crsfun_TW *** 1248 !! ** Purpose : Five applications. 1249 !! 1) Maximum surface quantity 1250 !! - Vertical scale factors (fse3t or fse3w) 1251 !! max thickness of the parent grid for coarse grid scale factors. 1252 !! - or diffusion test 1253 !! 2) Area-weighted mean quantity: w, or other 3D or 2D quantity 1254 !! 3) Volume-weighted mean quantity: tracer 1255 !! 4) Minimum surface quantity (diffusion test) 1256 !! 5) Area- or Volume- weighted sum. 1257 !! ** Method : 1) - cd_op = 'MAX'. Determines the max vertical thickness of grid boxes 1258 !! including partial steps for at the bottom 1259 !! for the coarsened grid, where within the subset of 1260 !! the parent grid cells the maximum thickness is taken. 1261 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1262 !! Where, normally p_pfield3d_1 is e3t. 1263 !! - cd_op = 'MAX'. May also be used for say, determining the maximum value of Kz, 1264 !! thus p_pfield3d_1 is set to the 3D field, Kz. 1265 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1266 !! 2) - cd_op = 'ARE'. Calculate the area-weighted average (surface e1t*e2t) 1267 !! of vertical velocity, w. 1268 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1269 !! - cd_op = 'ARE'. Calculate area-weighted average of a 2D quantity (e.g. emp) 1270 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield2d 1271 !! 3) - cd_op = 'VOL'. Calculate the ocean volume (e1e2t*[fse3t|fse3w]) 1272 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1273 !! - cd_op = 'VOL'. Calculate volume-weighted average (volume e1t*e2t*fse3t) of a quantity. 1274 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1, p_pfield3d_2 1275 !! 4) - cd_op = 'MIN'. Calculate the minimum value on surface e1t*e2t for 3D variables 1276 !! Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 1277 !! 5) - cd_op = 'SUM'. Calculate a dimesionally-weighted sum. This could be area-weighted 1278 !! or volume-weighted sum. 1279 !! ** Inputs : p_e1e2t = parent grid top face surface area, e1t*e2t 1280 !! cd_type = grid type T, W (U, V, F) 1281 !! cd_op = MAX, ARE, VOL, MIN, SUM 1282 !! p_cmask = coarse grid mask 1283 !! p_ptmask = parent grid tmask 1284 !! psgn = (Optional) sign for lbc_lnk 1285 !! p_pfield2d = (Optional) 2D field on parent grid 1286 !! p_pfield3d_1 = (Optional) parent grid fse3t or fse3w 1287 !! p_pfield3d_2 = (Optional) 3D field on parent grid 1288 !! ** Outputs : p_cfield2d = (Optional) 2D field on coarse grid 1289 !! p_cfield3d = (Optional) 3D field on coarse grid 1290 !! 1291 !! 1292 !! History. 30 May. Editing. To decide later: Keep all functionality or separate out the mean function. 1293 !! 7 Jun TODO. Need to fix up the parent grid mask to optional like crsfun_UV... 1294 !!---------------------------------------------------------------- 1295 !! 1296 !! Arguments 1297 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) 1298 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask 1299 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(in) :: p_e1, p_e2, p_e3 ! 3D tracer T or W on parent grid 1300 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), OPTIONAL, INTENT(out):: surf_crs, surf_msk_crs ! Coarse grid box east or north face quantity 1301 1302 !! Local variables 1303 INTEGER :: ji, jj, jk ! dummy loop indices 1304 INTEGER :: ijie,ijis,ijje,ijjs,ijpk,jii,jjj 1305 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze1, ze2, ze3 1306 REAL(wp), POINTER, DIMENSION(:,:,:) :: zsurf_crs, zsurf_msk_crs, zpmask 1307 !!---------------------------------------------------------------- 1308 ! Initialize 1309 1310 CALL wrk_alloc( jpi , jpj , jpk, ze1, ze2, ze3, zpmask ) 1311 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zsurf_crs, zsurf_msk_crs ) 1312 1313 ! Arrays, scalars initialization 1314 ze1(:,:,:) = p_e1(:,:,:) 1315 ze2(:,:,:) = p_e2(:,:,:) 1316 ze3(:,:,:) = p_e3(:,:,:) 1317 zsurf_crs(:,:,:) = 0.0 1318 zsurf_msk_crs(:,:,:) = 0.0 1319 zpmask(:,:,:) = p_mask(:,:,:) 1320 ijpk = jpk 1321 1322 SELECT CASE ( cd_type ) 1323 1324 CASE ('W') 1325 1326 DO jk = 2 , ijpk 1327 1328 DO ji = 2, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1329 ijie = mie_crs(ji) 1330 ijis = mis_crs(ji) 1331 jj = 1 1332 ijje = mje_crs(jj) 1333 ijjs = mjs_crs(jj) 1334 1335 DO jii = ijis, ijie 1336 DO jjj = ijjs, ijje 1337 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) + ze1(ji,jj,jk) * ze2(jii,jjj,jk) 1338 zsurf_msk_crs(ji,jj,jk) = zsurf_msk_crs(ji,jj,jk) & 1339 & + ( ze1(ji,jj,jk) * ze2(jii,jjj,jk) ) * zpmask(jii,jjj,jk-1) 1340 ENDDO 1341 ENDDO 1342 1343 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) * 3 1344 1345 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1346 ijje = mje_crs(jj) 1347 ijjs = mjs_crs(jj) 1348 1349 DO jii = ijis, ijie 1350 DO jjj = ijjs, ijje 1351 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) + ze1(ji,jj,jk) * ze2(jii,jjj,jk) 1352 zsurf_msk_crs(ji,jj,jk) = zsurf_msk_crs(ji,jj,jk) & 1353 & + ( ze1(ji,jj,jk) * ze2(jii,jjj,jk) ) * zpmask(jii,jjj,jk-1) 1354 ENDDO 1355 ENDDO 1356 ENDDO 1357 ENDDO 1358 ENDDO 1359 1360 jk = 1 !cas particulier ou on est en surface 1361 1362 DO ji = 1, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1363 ijie = mie_crs(ji) 1364 ijis = mis_crs(ji) 1365 IF( njstart == 1 ) THEN 1366 jj = 1 1367 ijje = mje_crs(jj) 1368 ijjs = mjs_crs(jj) 1369 1370 DO jii = ijis, ijie 1371 DO jjj = ijjs, ijje 1372 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) + ze1(ji,jj,jk) * ze2(jii,jjj,jk) 1373 zsurf_msk_crs(ji,jj,jk) = zsurf_msk_crs(ji,jj,jk) & 1374 & + ( ze1(ji,jj,jk) * ze2(jii,jjj,jk) ) * zpmask(jii,jjj,jk) 1375 ENDDO 1376 ENDDO 1377 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) * 3 1378 ENDIF 1379 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1380 ijje = mje_crs(jj) 1381 ijjs = mjs_crs(jj) 1382 DO jii = ijis, ijie 1383 DO jjj = ijjs, ijje 1384 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) + ze1(ji,jj,jk) * ze2(jii,jjj,jk) 1385 zsurf_msk_crs(ji,jj,jk) = zsurf_msk_crs(ji,jj,jk) & 1386 & + ( ze1(ji,jj,jk) * ze2(jii,jjj,jk) ) * zpmask(jii,jjj,jk) 1387 ENDDO 1388 ENDDO 1389 ENDDO 1390 ENDDO 1391 1392 CASE ('U') 1393 1394 DO jk = 1 , ijpk 1395 1396 DO ji = 1, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1397 ijie = mie_crs(ji) 1398 ijis = mis_crs(ji) 1399 IF( njstart == 1 ) THEN 1400 jj = 1 1401 ijje = mje_crs(jj) 1402 ijjs = mjs_crs(jj) 1403 1404 DO jii = ijis, ijie 1405 DO jjj = ijjs, ijje 1406 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) + ze3(ji,jj,jk) * ze2(jii,jjj,jk) 1407 zsurf_msk_crs(ji,jj,jk) = zsurf_msk_crs(ji,jj,jk) + ( ze3(ji,jj,jk) * ze2(jii,jjj,jk) ) * zpmask(jii,jjj,jk) 1408 ENDDO 1409 ENDDO 1410 1411 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) * 3 1412 ENDIF 1413 1414 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1415 ijje = mje_crs(jj) 1416 ijjs = mjs_crs(jj) 1417 1418 DO jii = ijis, ijie 1419 DO jjj = ijjs, ijje 1420 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) + ze3(ji,jj,jk) * ze2(jii,jjj,jk) 1421 zsurf_msk_crs(ji,jj,jk) = zsurf_msk_crs(ji,jj,jk) & 1422 & + ( ze3(ji,jj,jk) * ze2(jii,jjj,jk) ) * zpmask(jii,jjj,jk) 1423 ENDDO 1424 ENDDO 1425 ENDDO 1426 ENDDO 1427 ENDDO 1428 1429 CASE ('V') 1430 1431 DO jk = 1 , ijpk 1432 1433 DO ji = 1, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1434 ijie = mie_crs(ji) 1435 ijis = mis_crs(ji) 1436 1437 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1438 ijje = mje_crs(jj) 1439 ijjs = mjs_crs(jj) 1440 1441 DO jii = ijis, ijie 1442 DO jjj = ijjs, ijje 1443 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) + ze3(ji,jj,jk) * ze1(jii,jjj,jk) 1444 zsurf_msk_crs(ji,jj,jk) = zsurf_msk_crs(ji,jj,jk) & 1445 & + ( ze3(ji,jj,jk) * ze1(jii,jjj,jk) ) * zpmask(jii,jjj,jk) 1446 ENDDO 1447 ENDDO 1448 ENDDO 1449 ENDDO 1450 ENDDO 1451 END SELECT 1452 1453 surf_crs(:,:,:) = zsurf_crs(:,:,:) 1454 CALL crs_lbc_lnk( cd_type, 1.0, pt3d1=surf_crs ) 1455 ! lbcnlk met la ligne jpj = 1 a 0 donc il faut la remettre en ne pas oubliant le cyclique est-ouest 1456 ! a faire un case pour cyclique est-ouest ou non. 1457 surf_crs( : ,1,:) = zsurf_crs( : ,1,:) 1458 surf_crs( 1 ,1,:) = zsurf_crs(jpi_crsm1,1,:) 1459 surf_crs(jpi_crs,1,:) = zsurf_crs( 2 ,1,:) 1460 1461 surf_msk_crs(:,:,:) = zsurf_msk_crs(:,:,:) 1462 CALL crs_lbc_lnk( cd_type, 1.0, pt3d1=surf_msk_crs ) 1463 ! lbcnlk met la ligne jpj = 1 a 0 donc il faut la remettre en ne pas oubliant le cyclique est-ouest 1464 surf_msk_crs( : ,1,:) = zsurf_msk_crs( : ,1,:) 1465 surf_msk_crs( 1 ,1,:) = zsurf_msk_crs(jpi_crsm1,1,:) 1466 surf_msk_crs(jpi_crs,1,:) = zsurf_msk_crs( 2 ,1,:) 1467 1468 CALL wrk_dealloc( jpi , jpj , jpk, ze1, ze2, ze3, zpmask ) 1469 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zsurf_crs, zsurf_msk_crs ) 1470 1471 1472 END SUBROUTINE crs_surf 1473 358 END SUBROUTINE dom_grid_crs 359 360 361 !!====================================================================== 1474 362 1475 363 END MODULE crs 364 -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdiawri.F90
r3809 r3860 17 17 !! ! 2005-11 (V. Garnier) Surface pressure gradient organization 18 18 !! 3.2 ! 2008-11 (B. Lemaire) creation from old diawri 19 !! ! 2012-07 (J. Simeon, G. Madec, C. Ethe ) Modified for coarsened output19 !! ! 2012-07 (J. Simeon, G. Madec, C. Ethe, C. Calone) Modified for coarsened output 20 20 !!---------------------------------------------------------------------- 21 21 … … 52 52 USE timing ! preformance summary 53 53 USE wrk_nemo ! working array 54 USE crs_dom55 USE crs_iom56 54 USE crs 55 USE crsdom 56 USE crsiom 57 57 USE crslbclnk 58 ! USE crseosbn259 USE crs_iom60 58 61 59 IMPLICIT NONE … … 90 88 !!---------------------------------------------------------------------- 91 89 !! 90 92 91 INTEGER, INTENT( in ) :: kt ! ocean time-step index 93 92 !! … … 214 213 ENDDO 215 214 ENDDO 216 CALL crs_lbc_lnk( 'T', 1.0, pt3d1=hdivn_crs)215 CALL crs_lbc_lnk( hdivn_crs,'T', 1.0 ) 217 216 CALL crs_iom_put( "hdiv_crs", pv_r3d=hdivn_crs ) 218 217 … … 240 239 IF( nn_timing == 1 ) CALL timing_stop('crs_dia_wri') 241 240 ! 241 242 242 END SUBROUTINE crs_dia_wri 243 243 -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90
r3823 r3860 9 9 !! 4.0 ! 2011-01 (A. R. Porter, STFC Daresbury) dynamical allocation 10 10 !! ! 2012-06 (J. Simeon) Reduced and modified for coarse grid 11 !! ! 2012-10 (C. Calone) Reduced and modified for coarse grid 11 12 !!---------------------------------------------------------------------- 12 13 … … 16 17 USE timing ! Timing 17 18 USE dom_oce ! ocean space and time domain 18 USE crs_dom ! coarse grid domain19 19 USE in_out_manager ! I/O manager 20 USE crs_iom ! crs mediator to I/O library21 20 USE par_kind, ONLY: wp 22 !USE lib_mpp ! MPP library21 USE lib_mpp ! MPP library 23 22 ! USE wrk_nemo ! Memory allocation 24 USE crslbclnk ! crs mediator to lbclnk25 23 USE iom_def 26 24 USE iom 25 USE crs ! coarse grid domain 26 USE crsdom ! coarse grid domain 27 USE crsiom ! crs mediator to I/O library 28 USE crslbclnk ! crs mediator to lbclnk 29 30 27 31 28 32 IMPLICIT NONE … … 55 59 INTEGER :: inum3 ! temprary units for 'mesh_hgr.nc' file 56 60 INTEGER :: inum4 ! temprary units for 'mesh_zgr.nc' file 61 INTEGER :: iif, iil, ijf, ijl 57 62 CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations) 58 63 CHARACTER(len=21) :: clnam1 ! filename (mesh informations) … … 123 128 CALL crs_iom_rstput( 0, 0, inum2, 'fmask', pv_r3d=fmask_crs, ktype = jp_i1 ) 124 129 125 CALL crs_dom_uniq( zprw, 'T' ) 126 tmask_i_crs(:,:) = tmask_crs(:,:,1) * zprw ! ! unique point mask 127 CALL crs_iom_rstput( 0, 0, inum2, 'tmaskutil', pv_r2d=tmask_i_crs, ktype = jp_i1 ) 130 ! CALL crs_dom_uniq( zprw, 'T' ) 131 ! tmask_i_crs(:,:) = tmask_crs(:,:,1) * zprw 132 133 tmask_i_crs(:,:) = tmask_crs(:,:,1) 134 iif = jpreci 135 iil = nlci_crs - jpreci + 1 136 ijf = jpreci 137 ijl = nlcj_crs - jprecj + 1 138 139 tmask_i_crs( 1:iif , : ) = 0._wp 140 tmask_i_crs(iil:jpi_crs, : ) = 0._wp 141 tmask_i_crs( : , 1:ijf ) = 0._wp 142 tmask_i_crs( : ,ijl:jpj_crs) = 0._wp 143 144 145 146 !!! north fold mask_crs 147 148 tpol_crs(1:jpiglo_crs,:) = 1._wp 149 fpol_crs(1:jpiglo_crs,:) = 1._wp 150 IF( jperio == 3 .OR. jperio == 4 ) THEN 151 tpol_crs(jpiglo_crs/2+1:jpiglo_crs,:) = 0._wp 152 fpol_crs( 1 :jpiglo_crs,:) = 0._wp 153 IF( mjg_crs(nlej_crs) == jpiglo_crs ) THEN 154 DO ji = iif+1, iil-1 155 tmask_i_crs(ji,nlej_crs-1) = tmask_i_crs(ji,nlej_crs-1) & 156 & * tpol_crs(mig_crs(ji),1) 157 ENDDO 158 ENDIF 159 ENDIF 160 IF( jperio == 5 .OR. jperio == 6 ) THEN 161 tpol_crs( 1 :jpiglo_crs,:)=0._wp 162 fpol_crs(jpiglo_crs/2+1:jpiglo_crs,:)=0._wp 163 ENDIF 164 165 ! CALL crs_iom_rstput( 0, 0, inum2, 'tpol', pv_r2d=tpol_crs, ktype = jp_i1 ) 166 ! CALL crs_iom_rstput( 0, 0, inum2, 'fpol', pv_r2d=fpol_crs, ktype = jp_i1 ) 167 168 !!! 169 CALL crs_iom_rstput( 0, 0, inum2, 'tmaskutil', pv_r2d=tmask_i_crs, ktype = jp_i1 ) 170 ! ! unique point mask 128 171 CALL crs_dom_uniq( zprw, 'U' ) 129 172 zprt = umask_crs(:,:,1) * zprw … … 181 224 END DO 182 225 183 CALL crs_lbc_lnk( 'T', 1.0, ze3tp)184 CALL crs_lbc_lnk( 'W', 1.0, ze3wp)226 CALL crs_lbc_lnk( ze3tp,'T', 1.0 ) 227 CALL crs_lbc_lnk( ze3wp,'W', 1.0 ) 185 228 186 229 CALL crs_iom_rstput( 0, 0, inum4, 'e3t_ps', pv_r2d=ze3tp ) … … 199 242 END DO 200 243 201 CALL crs_lbc_lnk( 'U', 1.,pt3d1=zdepu ) ; CALL crs_lbc_lnk( 'V', 1.,pt3d1=zdepv)244 CALL crs_lbc_lnk( zdepu,'U', 1. ) ; CALL crs_lbc_lnk( zdepv,'V', 1. ) 202 245 CALL crs_iom_rstput( 0, 0, inum4, 'gdepu', pv_r3d=zdepu, ktype = jp_r4 ) 203 246 CALL crs_iom_rstput( 0, 0, inum4, 'gdepv', pv_r3d=zdepv, ktype = jp_r4 ) … … 270 313 IF( nn_timing == 1 ) CALL timing_stop('crs_dom_wri') 271 314 ! 315 272 316 END SUBROUTINE crs_dom_wri 273 317 … … 305 349 ! 306 350 puniq(:,:) = ztstref(:,:) ! default definition 307 CALL crs_lbc_lnk( cdgrd, 1.,puniq) ! apply boundary conditions351 CALL crs_lbc_lnk( puniq,cdgrd, 1. ) ! apply boundary conditions 308 352 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 309 353 ! … … 318 362 IF( nn_timing == 1 ) CALL timing_stop('crs_dom_uniq') 319 363 ! 364 320 365 END SUBROUTINE crs_dom_uniq 321 366 -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
r3823 r3860 4 4 !! Manage the grid coarsening module initialization 5 5 !!====================================================================== 6 !! History 2012-05 (J. Simeon, G. Madec, C. Ethe ) Original code6 !! History 2012-05 (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code 7 7 !!---------------------------------------------------------------------- 8 8 … … 10 10 USE par_oce ! For parameter jpi,jpj,jphgr_msh 11 11 USE dom_oce ! For parameters in par_oce (jperio, lk_vvl) 12 USE crs _dom! Coarse grid domain12 USE crs ! Coarse grid domain 13 13 USE phycst, ONLY: omega, rad ! physical constants 14 14 USE wrk_nemo 15 15 USE in_out_manager 16 16 USE par_kind, ONLY: wp 17 USE crs 17 USE crs_dom 18 18 USE crsdomwri 19 19 USE crslbclnk … … 64 64 !!------------------------------------------------------------------- 65 65 !! Local variables 66 INTEGER :: ji,jj,jk ,ijjgloT,ijis,ijie,ijjs,ijje,jn! dummy indices66 INTEGER :: ji,jj,jk ! dummy indices 67 67 INTEGER :: ierr ! allocation error status 68 REAL(wp) :: zrestx, zresty ! for determining odd or even reduction factor69 REAL(wp), DIMENSION(:,:) , POINTER :: zmbk70 68 REAL(wp), DIMENSION(:,:,:), POINTER :: zfse3t, zfse3u, zfse3v, zfse3w 71 LOGICAL :: llok72 69 73 70 NAMELIST/namcrs/ nn_factx, nn_facty, cn_binref, nn_fcrs, nn_msh_crs, cn_ocerstcrs … … 90 87 WRITE(numout,*) 91 88 WRITE(numout,*) 'crs_init: Namelist namcrs ' 92 WRITE(numout,*) ' nn_factx = ', nn_factx 93 WRITE(numout,*) ' nn_facty = ', nn_facty 94 WRITE(numout,*) ' cn_binref = ', cn_binref 95 WRITE(numout,*) ' nn_fcrs = ', nn_fcrs 96 WRITE(numout,*) ' nn_msh_crs = ', nn_msh_crs 89 WRITE(numout,*) ' nn_factx = ' , nn_factx 90 WRITE(numout,*) ' nn_facty = ' , nn_facty 91 WRITE(numout,*) ' cn_binref = ' , cn_binref 92 WRITE(numout,*) ' nn_fcrs = ' , nn_fcrs 93 WRITE(numout,*) ' nn_msh_crs = ' , nn_msh_crs 94 WRITE(numout,*) ' njmppt = ' , njmppt 97 95 ENDIF 98 96 99 rfactx_r = 1. /nn_factx100 rfacty_r = 1. /nn_facty97 rfactx_r = 1. / nn_factx 98 rfacty_r = 1. / nn_facty 101 99 102 100 !--------------------------------------------------------- 103 101 ! 2. Define Global Dimensions of the coarsened grid 104 102 !--------------------------------------------------------- 105 ! 2.a. Define global domain indices 106 jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2 107 jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj 108 jpiglo_crsm1 = jpiglo_crs - 1 109 jpjglo_crsm1 = jpjglo_crs - 1 110 111 ! 2.b. Define local domain indices 112 jpi_crs = ( jpiglo_crs-2 * jpreci + (jpni-1) ) / jpni + 2*jpreci 113 jpj_crs = ( jpjglo_crs-2 * jprecj + (jpnj-1) ) / jpnj + 2*jprecj 114 115 jpi_crsm1 = jpi_crs - 1 116 jpj_crsm1 = jpj_crs - 1 117 nperio_crs = jperio 118 npolj_crs = npolj 119 120 ierr = crs_dom_alloc() ! allocate most coarse grid arrays 121 122 IF( .NOT. lk_mpp ) THEN 123 nimpp_crs = 1 124 njmpp_crs = 1 125 nlci_crs = jpi_crs 126 nlcj_crs = jpj_crs 127 nldi_crs = 1 128 nldj_crs = 1 129 nlei_crs = jpi_crs 130 nlej_crs = jpj_crs 131 132 ELSE 133 ! Initialisation of most local variables - 134 nimpp_crs = 1 135 njmpp_crs = 1 136 nlci_crs = jpi_crs 137 nlcj_crs = jpj_crs 138 nldi_crs = 1 139 nldj_crs = 1 140 nlei_crs = jpi_crs 141 nlej_crs = jpj_crs 142 143 SELECT CASE ( npolj ) 144 145 CASE ( 0 ) 103 CALL crs_dom_def 104 105 !--------------------------------------------------------- 106 ! 3. Mask and Mesh 107 !--------------------------------------------------------- 108 109 ! Set up the masks and meshes 110 111 ! 3.a. Get the masks 146 112 147 nlej_crs = AINT( REAL( ( jpjglo - (njmpp - 1) ) / nn_facty, wp ) ) & 148 & - AINT( REAL( ( jpjglo - mjg(nlej-1) ) / nn_facty, wp ) ) 149 IF( noso == -1 ) THEN 150 IF( MOD( jpjglo - njmpp , nn_facty ) > 0 ) nlej_crs = nlej_crs + 1 151 ELSE 152 IF( MOD( jpjglo - njmpp + 1 , nn_facty ) > nn_facty / 2 ) nlej_crs = nlej_crs + 1 153 ENDIF 154 155 CASE ( 3, 4, 5, 6 ) 156 157 nlej_crs = AINT( REAL( ( jpjglo - (njmpp - 1) ) / nn_facty, wp ) ) & 158 & - AINT( REAL( ( jpjglo - mjg(nlej) + 1 ) / nn_facty, wp ) ) + 1 159 160 CASE DEFAULT 161 WRITE(numout,*) 'crs_init. Only jperio =0, 3, 4, 5, 6 supported' 162 STOP 163 END SELECT 164 165 IF (noso > -1) THEN 166 nlej_crs = nlej_crs + 1 167 nldj_crs = 2 168 ELSE 169 nldj_crs = 1 170 ENDIF 171 172 IF ( nono < jpnj ) THEN 173 nlcj_crs = nlej_crs + 1 174 ELSE 175 nlcj_crs = nlej_crs 176 ENDIF 177 178 njmpp_crs = jpjglo_crs - ANINT( REAL( (jpjglo - njmpp ) / nn_facty, wp ) ) - 1 179 IF( MOD( jpjglo - njmpp , nn_facty ) > nn_facty / 2 ) njmpp_crs = njmpp_crs - 1 180 181 ENDIF 182 183 CALL dom_grid_crs !swich de grille 184 185 186 IF (lwp) THEN 187 WRITE(numout,*) 188 WRITE(numout,*) 'crs_init : coarse grid dimensions' 189 WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo 190 WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo 191 WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi 192 WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj 193 WRITE(numout,*) 194 WRITE(numout,*) ' nproc = ', narea 195 WRITE(numout,*) ' nlci = ', nlci 196 WRITE(numout,*) ' nlcj = ', nlcj 197 WRITE(numout,*) ' nldi = ', nldi 198 WRITE(numout,*) ' nldj = ', nldj 199 WRITE(numout,*) ' nlei = ', nlei 200 WRITE(numout,*) ' nlej = ', nlej 201 WRITE(numout,*) ' nimpp = ', nimpp 202 WRITE(numout,*) ' njmpp = ', njmpp 203 WRITE(numout,*) 204 ENDIF 205 206 CALL dom_grid_glo 207 208 mxbinctr = INT( nn_factx * 0.5 ) 209 mybinctr = INT( nn_facty * 0.5 ) 210 211 zrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor 212 zresty = MOD( nn_facty, 2 ) 213 214 IF ( zrestx == 0 ) THEN 215 mxbinctr = mxbinctr - 1 216 ENDIF 217 218 IF ( zresty == 0 ) THEN 219 mybinctr = mybinctr - 1 220 IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2 221 IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2 222 223 IF ( npolj == 3 ) npolj_crs = 5 224 IF ( npolj == 5 ) npolj_crs = 3 225 ENDIF 226 227 rfactxy = nn_factx * nn_facty 228 229 230 !jes. TODO Need to deallocate these if ln_crs = F 231 232 233 ! jes. TODO. Add the next two lines when mpp is done 234 ! IF( lk_mpp ) CALL mpp_sum( ierr ) 235 ! IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' ) 236 237 238 ! 2.c. Set up bins for coarse grid, horizontal only. 239 240 mis_crs(:) = 0; mie_crs(:) = 0 241 mjs_crs(:) = 0; mje_crs(:) = 0 242 243 244 SELECT CASE ( cn_binref ) 245 246 CASE ( 'NORTH' ) 247 248 SELECT CASE ( npolj ) 249 !cc 250 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 251 252 DO ji = 2, jpiglo_crsm1 253 ijie = (ji*nn_factx)-nn_factx !cc 254 ijis = ijie-nn_factx+1 255 mis_crs(ji) = ijis 256 mie_crs(ji) = ijie 257 ENDDO 258 IF ( jpiglo - 1 - mie_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo-2 ! ijie = jpiglo-1 !cc 259 260 ! Handle first the northernmost bin 261 IF ( nn_facty == 2 ) THEN ; ijjgloT = jpjglo - 1 262 ELSE ; ijjgloT = jpjglo 263 ENDIF 264 265 DO jj = 2, jpjglo_crsm1 266 ijje = ijjgloT-nn_facty*(jj-2) 267 ijjs = ijje-nn_facty+1 268 mjs_crs(jpjglo_crs-jj+1) = ijjs 269 mje_crs(jpjglo_crs-jj+1) = ijje 270 ENDDO 271 272 CASE ( 2 ) 273 WRITE(numout,*) 'crs_init, jperio=2 not supported' 274 275 CASE ( 5, 6 ) ! F-pivot at North Fold 276 277 DO ji = 2, jpiglo_crsm1 278 ijie = (ji*nn_factx)-nn_factx 279 ijis = ijie-nn_factx+1 280 mis_crs(ji) = ijis 281 mie_crs(ji) = ijie 282 ENDDO 283 IF ( jpiglo - 1 - mie_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo-2 ! ijie = jpiglo-1 !cc 284 285 ! Treat the northernmost bin separately. 286 jj = 2 287 ijje = jpj-nn_facty*(jj-2) 288 IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 1 289 ELSE ; ijjs = ijje - nn_facty + 1 290 ENDIF 291 mjs_crs(jpj_crs-jj+1) = ijjs 292 mje_crs(jpj_crs-jj+1) = ijje 293 294 ! Now bin the rest, any remainder at the south is lumped in the southern bin 295 DO jj = 3, jpjglo_crsm1 296 ijje = jpjglo-nn_facty*(jj-2) 297 ijjs = ijje-nn_facty+1 298 IF ( ijjs <= nn_facty ) ijjs = 2 299 mjs_crs(jpj_crs-jj+1) = ijjs 300 mje_crs(jpj_crs-jj+1) = ijje 301 ENDDO 302 303 CASE DEFAULT 304 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' 305 306 END SELECT 307 308 CASE ( 'EQUAT' ) 309 WRITE(numout,*) 'crs_init. Equator-centered bins option not yet available' 310 311 END SELECT 312 313 314 ! Pad the boundaries, do not know if it is necessary 315 mis_crs(1) = 1 ; mis_crs(jpiglo_crs) = mie_crs(jpiglo_crs - 1) + 1 !cc 316 mie_crs(1) = nn_factx ; mie_crs(jpiglo_crs) = jpiglo !cc 317 ! Probleme de segmentation je sais pas pourquoi 318 mjs_crs(1) = 1 ; mjs_crs(jpjglo_crs) = mje_crs(jpjglo_crsm1) + 1 319 mje_crs(1) = mjs_crs(2)-1; mje_crs(jpjglo_crs) = jpjglo 320 321 ! WRITE(numout,*) 'crs_init. coarse grid bounds on parent grid' 322 ! WRITE(numout,*) 'mis_crs=', mis_crs 323 ! WRITE(numout,*) 'mie_crs=', mie_crs 324 ! WRITE(numout,*) 'mjs_crs=', mjs_crs 325 ! WRITE(numout,*) 'mje_crs=', mje_crs 326 327 328 IF( .NOT. lk_mpp ) THEN 329 njstart = 1 ; njend = jpj_crsm1 330 ELSE 331 ! 332 IF( noso == -1 ) THEN ; njstart = 1 333 ELSE ; njstart = 2 334 ENDIF 335 ! 336 IF( mje_crs(nlej_crs) >= jpj ) THEN ; njend = nlej_crs - 1 337 ELSE ; njend = nlej_crs 338 ENDIF 339 ! 340 ENDIF 341 342 !--------------------------------------------------------- 343 ! 3. Mask and Mesh 344 !--------------------------------------------------------- 345 346 ! Set up the masks and meshes 347 348 ! 3.a. Get the masks 349 CALL crsfun( p_ptmask=tmask, cd_type='T', p_cmask=tmask_crs ) 350 CALL crsfun( p_ptmask=umask, cd_type='U', p_cmask=umask_crs ) 351 CALL crsfun( p_ptmask=vmask, cd_type='V', p_cmask=vmask_crs ) 352 CALL crsfun( p_ptmask=fmask, cd_type='F', p_cmask=fmask_crs ) 353 354 355 ! CALL crsfun( p_ptmask=tmask, cd_type='T', p_pmask2d=rnfmsk, p_cmask2d=rnfmsk_crs ) 356 ! rnfmsk_crs(:,:) = rnfmsk_crs(:,:) * tmask_crs(:,:,1) 113 CALL crs_dom_msk 114 357 115 358 116 WRITE(numout,*) 'crsini. Finished masks' … … 362 120 ! Even-numbered reduction factor, center coordinate on U-,V- faces or f-corner. 363 121 ! 364 IF ( zresty /= 0 .AND. zrestx /= 0 ) THEN 365 366 CALL crsfun( gphit, glamt, 'T', gphit_crs, glamt_crs ) 367 ! WRITE(numout,*) 'crsini. gphit_crs(15,15)', gphit_crs(15,15) 368 ! WRITE(numout,*) 'crsini. glamt_crs(15,15)', glamt_crs(15,15) 369 370 ! WRITE(numout,*) 'crsini. count 1' 371 372 CALL crsfun( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) !cc 373 ! WRITE(numout,*) 'crsini. gphiu_crs(15,15)', gphiu_crs(15,15) !cc 374 ! WRITE(numout,*) 'crsini. glamu_crs(15,15)', glamu_crs(15,15) !cc 375 ! WRITE(numout,*) 'crsini. count 2' 376 377 CALL crsfun( p_pgphi=gphiv, p_pglam=glamv, cd_type='V', p_cgphi=gphiv_crs, p_cglam=glamv_crs ) !cc 378 ! WRITE(numout,*) 'crsini. gphiv_crs(15,15)', gphiv_crs(15,15) !cc 379 ! WRITE(numout,*) 'crsini. glamv_crs(15,15)', glamv_crs(15,15) !cc 380 381 ! WRITE(numout,*) 'crsini. count 3' 382 CALL crsfun( p_pgphi=gphif, p_pglam=glamf, cd_type='F', p_cgphi=gphif_crs, p_cglam=glamf_crs ) !cc 383 ! WRITE(numout,*) 'crsini. gphif_crs(15,15)', gphif_crs(15,15) !cc 384 ! WRITE(numout,*) 'crsini. glamf_crs(15,15)', glamf_crs(15,15) !cc 385 386 ! WRITE(numout,*) 'crsini. count 4' 387 ELSEIF ( zresty /= 0 .AND. zrestx == 0 ) THEN 388 CALL crsfun( p_pgphi=gphiu, p_pglam=glamu, cd_type='T', p_cgphi=gphit_crs, p_cglam=glamt_crs ) 389 CALL crsfun( p_pgphi=gphiu, p_pglam=glamu, cd_type='U', p_cgphi=gphiu_crs, p_cglam=glamu_crs ) 390 CALL crsfun( p_pgphi=gphif, p_pglam=glamf, cd_type='V', p_cgphi=gphiv_crs, p_cglam=glamv_crs ) 391 CALL crsfun( p_pgphi=gphif, p_pglam=glamf, cd_type='F', p_cgphi=gphif_crs, p_cglam=glamf_crs ) 392 ELSEIF ( zresty == 0 .AND. zrestx /= 0 ) THEN 393 CALL crsfun( p_pgphi=gphiv, p_pglam=glamv, cd_type='T', p_cgphi=gphit_crs, p_cglam=glamt_crs ) 394 CALL crsfun( p_pgphi=gphif, p_pglam=glamf, cd_type='U', p_cgphi=gphiu_crs, p_cglam=glamu_crs ) 395 CALL crsfun( p_pgphi=gphiv, p_pglam=glamv, cd_type='V', p_cgphi=gphiv_crs, p_cglam=glamv_crs ) 396 CALL crsfun( p_pgphi=gphif, p_pglam=glamf, cd_type='F', p_cgphi=gphif_crs, p_cglam=glamf_crs ) 122 IF ( nresty /= 0 .AND. nrestx /= 0 ) THEN 123 CALL crs_dom_coordinates( gphit, glamt, 'T', gphit_crs, glamt_crs ) 124 CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) 125 CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) 126 CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 127 ELSEIF ( nresty /= 0 .AND. nrestx == 0 ) THEN 128 CALL crs_dom_coordinates( gphiu, glamu, 'T', gphit_crs, glamt_crs ) 129 CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) 130 CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) 131 CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 132 ELSEIF ( nresty == 0 .AND. nrestx /= 0 ) THEN 133 CALL crs_dom_coordinates( gphiv, glamv, 'T', gphit_crs, glamt_crs ) 134 CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) 135 CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) 136 CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 397 137 ELSE 398 CALL crs fun( p_pgphi=gphif, p_pglam=glamf, cd_type='T', p_cgphi=gphit_crs, p_cglam=glamt_crs )399 CALL crs fun( p_pgphi=gphif, p_pglam=glamf, cd_type='U', p_cgphi=gphiu_crs, p_cglam=glamu_crs )400 CALL crs fun( p_pgphi=gphif, p_pglam=glamf, cd_type='V', p_cgphi=gphiv_crs, p_cglam=glamv_crs )401 CALL crs fun( p_pgphi=gphif, p_pglam=glamf, cd_type='F', p_cgphi=gphif_crs, p_cglam=glamf_crs )138 CALL crs_dom_coordinates( gphif, glamf, 'T', gphit_crs, glamt_crs ) 139 CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) 140 CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) 141 CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 402 142 ENDIF 403 143 … … 407 147 408 148 ! 3.c.1 Horizontal scale factors 409 ! CALL crsfun( cd_type='T', cd_op='SUM', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_cfield2d_1=e1t_crs, p_cfield2d_2=e2t_crs ) 410 ! CALL crsfun( cd_type='U', cd_op='SUM', p_pmask=umask, p_e1=e1u, p_e2=e2u, p_cfield2d_1=e1u_crs, p_cfield2d_2=e2u_crs ) 411 ! CALL crsfun( cd_type='V', cd_op='SUM', p_pmask=vmask, p_e1=e1v, p_e2=e2v, p_cfield2d_1=e1v_crs, p_cfield2d_2=e2v_crs ) 412 ! CALL crsfun( cd_type='F', cd_op='SUM', p_pmask=fmask, p_e1=e1f, p_e2=e2f, p_cfield2d_1=e1f_crs, p_cfield2d_2=e2f_crs ) 413 CALL crsfun( cd_type='T', cd_op='POS', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_cfield2d_1=e1t_crs, p_cfield2d_2=e2t_crs ) 414 CALL crsfun( cd_type='U', cd_op='POS', p_pmask=umask, p_e1=e1u, p_e2=e2u, p_cfield2d_1=e1u_crs, p_cfield2d_2=e2u_crs ) 415 CALL crsfun( cd_type='V', cd_op='POS', p_pmask=vmask, p_e1=e1v, p_e2=e2v, p_cfield2d_1=e1v_crs, p_cfield2d_2=e2v_crs ) 416 CALL crsfun( cd_type='F', cd_op='POS', p_pmask=fmask, p_e1=e1f, p_e2=e2f, p_cfield2d_1=e1f_crs, p_cfield2d_2=e2f_crs ) 149 150 CALL crs_dom_hgr( e1t, e2t, ,'T', e1t_crs, e2t_crs ) 151 CALL crs_dom_hgr( e1u, e2u, ,'U', e1u_crs, e2u_crs ) 152 CALL crs_dom_hgr( e1v, e2v, ,'V', e1v_crs, e2v_crs ) 153 CALL crs_dom_hgr( e1f, e2f, ,'F', e1f_crs, e2f_crs ) 417 154 418 155 e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:) 419 156 420 157 WRITE(numout,*) 'crsini. Finished horizontal scale factors' 421 158 422 159 ! 3.c.2 Coriolis factor 423 160 … … 434 171 END SELECT 435 172 436 437 ! 3.d. Get the initial vertical mesh438 ! nav_lon(jpi,jpj), nav_lat(jpi,jpj)439 ! nav_lev(jpk), e3t_0(jpk), e3w_0(jpk), gdep[t,w]_0(jpk) -> these stay constant440 ! 2D: mbathy (k-levels)441 ! 3D: fse3[t,u,v,w,f] (scale factors), gdep[t,u,v,w] (depth in meters)442 443 ! jes. TODO. Could probably make optional e1e2t in crsfun_TW...444 445 173 ! 3.d.1 mbathy ( vertical k-levels of bathymetry ) 446 174 447 mbathy_crs(:,:) = jpkm1 448 mbkt_crs(:,:) = 1 449 mbku_crs(:,:) = 1 450 mbkv_crs(:,:) = 1 451 452 453 DO jj = 1, jpj_crs 454 DO ji = 1, jpi_crs 455 jk = 0 456 DO WHILE( tmask_crs(ji,jj,jk+1) > 0.) 457 jk = jk + 1 458 ENDDO 459 mbathy_crs(ji,jj) = float( jk ) 460 ENDDO 461 ENDDO 462 463 CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 464 465 zmbk(:,:) = 0.0 466 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk('T',1.0,zmbk) ; mbathy_crs(:,:) = INT( zmbk(:,:) ) 467 468 469 ! 470 IF(lwp) WRITE(numout,*) 471 IF(lwp) WRITE(numout,*) ' crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels ' 472 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' 473 ! 474 mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) 475 ! ! bottom k-index of W-level = mbkt+1 476 477 DO jj = 1, jpj_crsm1 ! bottom k-index of u- (v-) level 478 DO ji = 1, jpi_crsm1 479 mbku_crs(ji,jj) = MIN( mbkt_crs(ji+1,jj ) , mbkt_crs(ji,jj) ) 480 mbkv_crs(ji,jj) = MIN( mbkt_crs(ji ,jj+1) , mbkt_crs(ji,jj) ) 481 END DO 482 END DO 483 484 WRITE(numout,*) 'crsini. Set mbku, mkbv' 485 486 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 487 zmbk(:,:) = 1.e0 488 zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk('U',1.0,zmbk) ; mbku_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 489 zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk('V',1.0,zmbk) ; mbkv_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 490 ! 491 492 WRITE(numout,*) 'crs_init = finished section 3d.1 jpi=', jpi, 'jpj=',jpj, ' jpk=', jpk 175 CALL crs_dom_bat 493 176 494 177 ! 3.d.2 Vertical scale factors … … 499 182 zfse3v(:,:,:) = fse3v(:,:,:) 500 183 zfse3w(:,:,:) = fse3w(:,:,:) 501 184 502 185 503 186 WRITE(numout,*) 'crs_init : beginning section 3.d.2 ! ' 504 !CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='MAX', p_cmask=tmask_crs, & 505 ! & p_ptmask=tmask, p_pfield3d_1=zfse3t, p_cfield3d=e3t_crs ) 506 !CALL crsfun( p_e1e2t=e1e2t, cd_type='W', cd_op='MAX', p_cmask=tmask_crs, & 507 ! & p_ptmask=tmask, p_pfield3d_1=zfse3w, p_cfield3d=e3w_crs ) 508 !CALL crsfun( p_e1e2t=e1e2t, cd_type='U', cd_op='MIN', p_cmask=umask_crs, p_ptmask=umask, p_pfield3d_1=zfse3u, p_cfield3d=e3u_crs ) 509 !CALL crsfun( p_e1e2t=e1e2t, cd_type='V', cd_op='MIN', p_cmask=vmask_crs, p_ptmask=vmask, p_pfield3d_1=zfse3v, p_cfield3d=e3v_crs ) 510 !CALL crsfun( p_e1e2t=e1e2t, cd_type='F', cd_op='MIN', p_cmask=fmask_crs, p_ptmask=fmask, p_pfield3d_1=zfse3f, p_cfield3d=e3f_crs ) 187 188 CALL crs_dom_e3_max( zfse3t, 'T', tmask, e3t_crs) 189 CALL crs_dom_e3_max( zfse3w, 'W', tmask, e3w_crs) 190 511 191 512 CALL crs_e3_max( p_e3=zfse3t, cd_type='T', p_mask=tmask, p_e3_crs=e3t_crs)513 CALL crs_e3_max( p_e3=zfse3w, cd_type='W', p_mask=tmask, p_e3_crs=e3w_crs)514 515 192 WRITE(numout,*) 'crs_init : crs_e3_max ' 516 193 … … 532 209 533 210 CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, & 534 & p_pfield3d_1=gdept, p_cfield3d=gdept_crs ) 211 & p_pfield3d_1=gdept, p_cfield3d=gdept_crs ) 535 212 CALL crsfun( p_e1e2t=e1e2t, cd_type='W', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, & 536 213 & p_pfield3d_1=gdepw, p_cfield3d=gdepw_crs ) 537 214 538 215 ! 3.d.4 Surfaces 539 540 CALL crs_ surf(p_e1=e1t, p_e2=e2t ,p_e3=zfse3w, cd_type='W', p_mask=tmask, surf_crs=e1e2w, surf_msk_crs=e1e2w_msk)541 CALL crs_ surf(p_e1=e1u, p_e2=e2u ,p_e3=zfse3u, cd_type='U', p_mask=umask, surf_crs=e2e3u, surf_msk_crs=e2e3u_msk)542 CALL crs_ surf(p_e1=e1v, p_e2=e2v ,p_e3=zfse3v, cd_type='V', p_mask=vmask, surf_crs=e1e3v, surf_msk_crs=e1e3v_msk)543 216 217 CALL crs_dom_sfc( e1t, e2t, zfse3w, 'W', tmask, e1e2w, e1e2w_msk ) 218 CALL crs_dom_sfc( e1u, e2u, zfse3u, 'U', umask, e2e3u, e2e3u_msk ) 219 CALL crs_dom_sfc( e1v, e2v, zfse3v, 'V', vmask, e1e3v, e1e3v_msk ) 220 544 221 545 222 !--------------------------------------------------------- … … 549 226 550 227 !! ! jes. May not need ocean_volume_crs_t, ocean_volume_crs_w as calculated already in trc_init as cvol 551 CALL crsfun ( cd_type='T', cd_op='VOL', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3t, &228 CALL crsfun_wgt( cd_type='T', cd_op='VOL', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3t, & 552 229 & p_cfield3d_1=ocean_volume_crs_t, p_cfield3d_2=facvol_t ) 553 230 … … 556 233 WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp/bt_crs(:,:,:) 557 234 558 CALL crsfun ( cd_type='W', cd_op='VOL', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3w, &235 CALL crsfun_wgt( cd_type='W', cd_op='VOL', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3w, & 559 236 & p_cfield3d_1=ocean_volume_crs_w, p_cfield3d_2=facvol_w ) 560 237 561 CALL crsfun( cd_type='U', cd_op='SUM', p_pmask=umask, p_e1=e1u, p_e2=e2u, p_fse3=zfse3u, p_cfield3d_1=facsurfu )562 CALL crsfun( cd_type='V', cd_op='SUM', p_pmask=vmask, p_e1=e1v, p_e2=e2v, p_fse3=zfse3v, p_cfield3d_1=facsurfv )563 564 565 ! 4.b. V, U and W surface area weights566 CALL crsfun( cd_type='U', cd_op='WGT', p_pmask=umask, p_e1=e1u, p_e2=e2u, p_fse3=zfse3u, p_cfield3d_1=crs_surfu_wgt )567 CALL crsfun( cd_type='V', cd_op='WGT', p_pmask=vmask, p_e1=e1v, p_e2=e2v, p_fse3=zfse3v, p_cfield3d_1=crs_surfv_wgt )568 CALL crsfun( cd_type='W', cd_op='WGT', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_cfield3d_1=crs_surfw_wgt )569 570 238 ! 4.c. T volume weights 571 CALL crsfun ( cd_type='T', cd_op='WGT', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3t, p_cfield3d_1=crs_volt_wgt )239 CALL crsfun_wgt( cd_type='T', cd_op='WGT', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3t, p_cfield3d_1=crs_volt_wgt ) 572 240 573 241 !--------------------------------------------------------- … … 575 243 !--------------------------------------------------------- 576 244 IF ( nn_msh_crs > 0 ) CALL crs_dom_wri 577 245 246 WRITE(numout,*) ' minimum e1T', MINVAL(e1t_crs) 578 247 WRITE(numout,*) 'crs_init done' 579 248 … … 581 250 ! 7. Finish and clean-up 582 251 !--------------------------------------------------------- 583 CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk )584 252 CALL wrk_dealloc(jpi, jpj, jpk, zfse3t, zfse3u, zfse3v, zfse3w ) 585 253 -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90
r3738 r3860 6 6 !! Ocean : lateral boundary conditions for grid coarsening 7 7 !!===================================================================== 8 !! History : ! 2012-06 (J. Simeon, G. Madec, C. Ethe ) Original code8 !! History : ! 2012-06 (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code 9 9 10 10 USE dom_oce 11 USE crs _dom11 USE crs 12 12 USE lbclnk 13 13 USE par_kind, ONLY: wp 14 14 USE in_out_manager 15 15 16 17 18 INTERFACE crs_lbc_lnk 19 MODULE PROCEDURE crs_lbc_lnk_3d, crs_lbc_lnk_3d_gather, crs_lbc_lnk_2d 20 END INTERFACE 21 16 22 PUBLIC crs_lbc_lnk 23 24 CONTAINS 17 25 18 CONTAINS 19 20 SUBROUTINE crs_lbc_lnk( cd_type1, psgn, pt2d, pt3d1, pt3d2, cd_type2, cd_mpp ) 26 SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, cd_mpp, pval ) 21 27 !!--------------------------------------------------------------------- 22 28 !! *** SUBROUTINE crs_lbc_lnk *** … … 32 38 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 33 39 34 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout), OPTIONAL :: pt2d ! 2D array on which the lbc is applied 35 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout), OPTIONAL :: pt3d1 ! 3D array on which the lbc is applied 36 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout), OPTIONAL :: pt3d2 37 38 CHARACTER(len=1) , INTENT(in ), OPTIONAL :: cd_type2 ! grid type 40 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied 41 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! valeur sur les halo 39 42 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 43 44 !! local vairables 45 LOGICAL :: ll_grid_crs 46 REAL(wp) :: zval ! valeur sur les halo 40 47 41 48 !!---------------------------------------------------------------------- 49 50 ll_grid_crs = ( jpi == jpi_crs ) 51 52 IF( PRESENT(pval) ) THEN ; zval = pval 53 ELSE ; zval = 0.0 54 ENDIF 55 56 IF( .NOT. ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 42 57 43 CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 44 45 IF ( PRESENT( pt2d ) ) THEN 46 47 IF ( PRESENT( cd_mpp ) ) THEN 48 CALL lbc_lnk( pt2d, cd_type1, psgn, cd_mpp ) 49 ELSE 50 CALL lbc_lnk( pt2d, cd_type1, psgn ) 51 ENDIF 52 53 ELSEIF ( PRESENT(pt3d1) .AND. PRESENT(pt3d2) ) THEN 54 55 CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 56 57 ELSEIF ( PRESENT(pt3d1) ) THEN 58 59 IF ( PRESENT( cd_mpp ) ) THEN 60 CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp ) 61 ELSE 62 CALL lbc_lnk( pt3d1, cd_type1, psgn ) 63 ENDIF 64 65 ELSE 66 67 WRITE(numout, *) 'crslbclnk. Must supply a 2d or 3d field' 68 STOP 69 58 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval ) 59 ELSE ; CALL lbc_lnk( pt3d1, cd_type1, psgn, pval=zval ) 70 60 ENDIF 71 61 72 CALL dom_grid_glo ! Return to parent grid domain62 IF( .NOT. ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain 73 63 74 END SUBROUTINE crs_lbc_lnk 64 END SUBROUTINE crs_lbc_lnk_3d 65 66 SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 67 !!--------------------------------------------------------------------- 68 !! *** SUBROUTINE crs_lbc_lnk *** 69 !! 70 !! ** Purpose : set lateral boundary conditions for coarsened grid 71 !! 72 !! ** Method : Swap domain indices from full to coarse domain 73 !! before arguments are passed directly to lbc_lnk. 74 !! Upon exiting, switch back to full domain indices. 75 !!---------------------------------------------------------------------- 76 !! Arguments 77 CHARACTER(len=1) , INTENT(in ) :: cd_type1,cd_type2 ! grid type 78 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 79 80 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1,pt3d2 ! 3D array on which the lbc is applied 81 82 !! local vairables 83 LOGICAL :: ll_grid_crs 84 !!---------------------------------------------------------------------- 85 86 ll_grid_crs = ( jpi == jpi_crs ) 87 88 IF( .NOT. ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 89 90 CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 91 92 IF( .NOT. ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain 93 94 END SUBROUTINE crs_lbc_lnk_3d_gather 95 96 97 98 SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval) 99 !!--------------------------------------------------------------------- 100 !! *** SUBROUTINE crs_lbc_lnk *** 101 !! 102 !! ** Purpose : set lateral boundary conditions for coarsened grid 103 !! 104 !! ** Method : Swap domain indices from full to coarse domain 105 !! before arguments are passed directly to lbc_lnk. 106 !! Upon exiting, switch back to full domain indices. 107 !!---------------------------------------------------------------------- 108 !! Arguments 109 CHARACTER(len=1) , INTENT(in ) :: cd_type ! grid type 110 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 111 112 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 113 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! valeur sur les halo 114 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 115 !! local variables 116 117 LOGICAL :: ll_grid_crs 118 REAL(wp) :: zval ! valeur sur les halo 119 120 !!---------------------------------------------------------------------- 121 122 ll_grid_crs = ( jpi == jpi_crs ) 123 124 IF( PRESENT(pval) ) THEN ; zval = pval 125 ELSE ; zval = 0.0 126 ENDIF 127 128 IF( .NOT. ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 129 130 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval ) 131 ELSE ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval ) 132 ENDIF 133 134 IF( .NOT. ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain 135 136 END SUBROUTINE crs_lbc_lnk_2d 75 137 76 138
Note: See TracChangeset
for help on using the changeset viewer.
