Changeset 13204 for utils/tools/DOMAINcfg
- Timestamp:
- 2020-07-02T10:38:35+02:00 (4 years ago)
- Location:
- utils/tools/DOMAINcfg
- Files:
-
- 8 deleted
- 33 edited
- 27 copied
Legend:
- Unmodified
- Added
- Removed
-
utils/tools/DOMAINcfg/cpp_DOMAINcfg.fcm
r12442 r13204 1 bld::tool::fppkeys key_mpp_mpi1 bld::tool::fppkeys -
utils/tools/DOMAINcfg/namelist_cfg
r12414 r13204 15 15 &namdom ! space and time domain (bathymetry, mesh, timestep) 16 16 !----------------------------------------------------------------------- 17 nn_bathy = 1 ! compute analyticaly (=0) or read (=1) the bathymetry file 18 ! or compute (2) from external bathymetry 19 nn_interp = 1 ! type of interpolation (nn_bathy =2) 20 cn_topo = 'bathymetry_ORCA12_V3.3.nc' ! external topo file (nn_bathy =2) 21 cn_bath = 'Bathymetry' ! topo name in file (nn_bathy =2) 22 cn_lon = 'nav_lon' ! lon name in file (nn_bathy =2) 23 cn_lat = 'nav_lat' ! lat name in file (nn_bathy =2) 24 rn_scale = 1 25 rn_bathy = 0. ! value of the bathymetry. if (=0) bottom flat at jpkm1 26 jphgr_msh = 0 ! type of horizontal mesh 27 ppglam0 = 999999.0 ! longitude of first raw and column T-point (jphgr_msh = 1) 28 ppgphi0 = 999999.0 ! latitude of first raw and column T-point (jphgr_msh = 1) 29 ppe1_deg = 999999.0 ! zonal grid-spacing (degrees) 30 ppe2_deg = 999999.0 ! meridional grid-spacing (degrees) 31 ppe1_m = 999999.0 ! zonal grid-spacing (degrees) 32 ppe2_m = 999999.0 ! meridional grid-spacing (degrees) 33 ppsur = -4762.96143546300 ! ORCA r4, r2 and r05 coefficients 34 ppa0 = 255.58049070440 ! (default coefficients) 35 ppa1 = 245.58132232490 ! 36 ppkth = 21.43336197938 ! 37 ppacr = 3.0 ! 38 ppdzmin = 999999. ! Minimum vertical spacing 39 pphmax = 999999. ! Maximum depth 40 ldbletanh = .FALSE. ! Use/do not use double tanf function for vertical coordinates 41 ppa2 = 999999. ! Double tanh function parameters 42 ppkth2 = 999999. ! 43 ppacr2 = 999999. ! 17 44 / 18 45 !----------------------------------------------------------------------- 19 46 &namcfg ! parameters of the configuration 20 47 !----------------------------------------------------------------------- 48 ! 49 ln_e3_dep = .true. ! =T : e3=dk[depth] in discret sens. 50 ! ! ===>>> will become the only possibility in v4.0 51 ! ! =F : e3 analytical derivative of depth function 52 ! ! only there for backward compatibility test with v3.6 53 ! ! 54 cp_cfg = "orca" ! name of the configuration 55 jp_cfg = 2 ! resolution of the configuration 56 jpidta = 182 ! 1st lateral dimension ( >= jpi ) 57 jpjdta = 149 ! 2nd " " ( >= jpj ) 58 jpkdta = 31 ! number of levels ( >= jpk ) 59 jpiglo = 182 ! 1st dimension of global domain --> i =jpidta 60 jpjglo = 149 ! 2nd - - --> j =jpjdta 61 jperio = 4 ! lateral cond. type (between 0 and 6) 62 ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present 63 ! in netcdf input files, as the start j-row for reading 64 ln_domclo = .false. ! computation of closed sea masks (see namclo) 21 65 / 22 66 !----------------------------------------------------------------------- 23 67 &namzgr ! vertical coordinate (default: NO selection) 24 68 !----------------------------------------------------------------------- 69 !----------------------------------------------------------------------- 70 ln_zco = .false. ! z-coordinate - full steps 71 ln_zps = .true. ! z-coordinate - partial steps 72 ln_sco = .false. ! s- or hybrid z-s-coordinate 73 ln_isfcav = .false. ! ice shelf cavity (T: see namzgr_isf) 25 74 / 26 75 !----------------------------------------------------------------------- … … 45 94 / 46 95 !----------------------------------------------------------------------- 47 &nambdy ! unstructured open boundaries (default: OFF)48 !-----------------------------------------------------------------------49 /50 !-----------------------------------------------------------------------51 96 &namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") 52 97 !----------------------------------------------------------------------- … … 55 100 &nammpp ! Massively Parallel Processing ("key_mpp_mpi") 56 101 !----------------------------------------------------------------------- 102 jpni = 0 103 jpnj=0 57 104 / 58 !-----------------------------------------------------------------------59 &namctl ! Control prints (default: OFF)60 !-----------------------------------------------------------------------61 / -
utils/tools/DOMAINcfg/namelist_ref
r12414 r13204 9 9 &namrun ! parameters of the run 10 10 !----------------------------------------------------------------------- 11 nn_no = 0 ! Assimilation cycle index12 11 cn_exp = "ORCA2" ! experience name 13 12 nn_it000 = 1 ! first time step … … 16 15 nn_time0 = 0 ! initial time of day in hhmm 17 16 nn_leapy = 0 ! Leap year calendar (1) or not (0) 18 ln_rstart = .false. ! start from rest (F) or from a restart file (T)19 nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T20 nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T21 ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist22 ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart23 ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart24 cn_ocerst_in = "restart" ! suffix of ocean restart name (input)25 cn_ocerst_indir = "." ! directory from which to read input ocean restarts26 cn_ocerst_out = "restart" ! suffix of ocean restart name (output)27 cn_ocerst_outdir = "." ! directory in which to write output ocean restarts28 ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model29 nn_istate = 0 ! output the initial state (1) or not (0)30 ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F)31 nn_stock = 5840 ! frequency of creation of a restart file (modulo referenced to 1)32 nn_stocklist = 0,0,0,0,0,0,0,0,0,0 ! List of timesteps when a restart file is to be written33 nn_write = 5475 ! frequency of write in the output file (modulo referenced to nn_it000)34 17 ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%) 35 ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard36 18 ln_clobber = .true. ! clobber (overwrite) an existing file 37 19 nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) 20 ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard 21 ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model 38 22 / 39 23 !----------------------------------------------------------------------- 40 24 &namdom ! space and time domain (bathymetry, mesh, timestep) 41 25 !----------------------------------------------------------------------- 42 nn_bathy = 1 ! compute (=0) or read (=1) the bathymetry file 26 ln_read_cfg = .false. ! Read from a domain_cfg file 27 nn_bathy = 1 ! compute analyticaly (=0) or read (=1) the bathymetry file 28 ! or compute (2) from external bathymetry 29 nn_interp = 1 ! type of interpolation (nn_bathy =2) 30 cn_domcfg = ' ' ! Name of the domain_cfg input file 31 cn_topo = 'bathymetry_ORCA12_V3.3.nc' ! external topo file (nn_bathy =2) 32 cn_bath = 'Bathymetry' ! topo name in file (nn_bathy =2) 33 cn_lon = 'nav_lon' ! lon name in file (nn_bathy =2) 34 cn_lat = 'nav_lat' ! lat name in file (nn_bathy =2) 43 35 rn_bathy = 0. ! value of the bathymetry. if (=0) bottom flat at jpkm1 44 36 nn_msh = 0 ! create (=1) a mesh file or not (=0) … … 82 74 ! ! =F : e3 analytical derivative of depth function 83 75 ! ! only there for backward compatibility test with v3.6 84 ! 85 cp_cfg = "default" ! name of the configuration 86 cp_cfz = "no zoom" ! name of the zoom of configuration 87 jp_cfg = 0 ! resolution of the configuration 88 jpkdta = 31 ! number of levels ( >= jpk ) 89 jpiglo = 10 ! 1st dimension of global domain --> i =jpidta 90 jpjglo = 12 ! 2nd - - --> j =jpjdta 91 jperio = 0 ! lateral cond. type (between 0 and 6) 92 ! = 0 closed ; = 1 cyclic East-West 93 ! = 2 equatorial symmetric ; = 3 North fold T-point pivot 94 ! = 4 cyclic East-West AND North fold T-point pivot 95 ! = 5 North fold F-point pivot 96 ! = 6 cyclic East-West AND North fold F-point pivot 76 ! ! 77 cp_cfg = "orca" ! name of the configuration 78 jp_cfg = 2 ! resolution of the configuration 79 jpidta = 182 ! 1st lateral dimension ( >= jpi ) 80 jpjdta = 149 ! 2nd " " ( >= jpj ) 81 jpkdta = 31 ! number of levels ( >= jpk ) 82 jpiglo = 182 ! 1st dimension of global domain --> i =jpidta 83 jpjglo = 149 ! 2nd - - --> j =jpjdta 84 jperio = 4 ! lateral cond. type (between 0 and 6) 97 85 ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present 98 86 ! in netcdf input files, as the start j-row for reading … … 106 94 ln_sco = .false. ! s- or hybrid z-s-coordinate 107 95 ln_isfcav = .false. ! ice shelf cavity (T: see namzgr_isf) 108 ln_linssh = .false. ! linear free surface109 96 / 110 97 !----------------------------------------------------------------------- … … 182 169 rn_sponge_tra = 2880. ! coefficient for tracer sponge layer [m2/s] 183 170 rn_sponge_dyn = 2880. ! coefficient for dynamics sponge layer [m2/s] 184 ln_chk_bathy = .false. ! =T check the parent bathymetry 185 / 186 !----------------------------------------------------------------------- 187 &nambdy ! unstructured open boundaries (default: OFF) 188 !----------------------------------------------------------------------- 189 ln_bdy = .false. ! Use unstructured open boundaries 190 nb_bdy = 0 ! number of open boundary sets 191 ln_coords_file = .true. ! =T : read bdy coordinates from file 192 cn_coords_file = 'coordinates.bdy.nc' ! bdy coordinates files 193 ln_mask_file = .false. ! =T : read mask from file 194 cn_mask_file = '' ! name of mask file (if ln_mask_file=.TRUE.) 195 cn_dyn2d = 'none' ! 196 nn_dyn2d_dta = 0 ! = 0, bdy data are equal to the initial state 197 ! ! = 1, bdy data are read in 'bdydata .nc' files 198 ! ! = 2, use tidal harmonic forcing data from files 199 ! ! = 3, use external data AND tidal harmonic forcing 200 cn_dyn3d = 'none' ! 201 nn_dyn3d_dta = 0 ! = 0, bdy data are equal to the initial state 202 ! ! = 1, bdy data are read in 'bdydata .nc' files 203 cn_tra = 'none' ! 204 nn_tra_dta = 0 ! = 0, bdy data are equal to the initial state 205 ! ! = 1, bdy data are read in 'bdydata .nc' files 206 cn_ice = 'none' ! 207 nn_ice_dta = 0 ! = 0, bdy data are equal to the initial state 208 ! ! = 1, bdy data are read in 'bdydata .nc' files 209 rn_ice_tem = 270. ! si3 only: arbitrary temperature of incoming sea ice 210 rn_ice_sal = 10. ! si3 only: -- salinity -- 211 rn_ice_age = 30. ! si3 only: -- age -- 212 ! 213 ln_tra_dmp =.false. ! open boudaries conditions for tracers 214 ln_dyn3d_dmp =.false. ! open boundary condition for baroclinic velocities 215 rn_time_dmp = 1. ! Damping time scale in days 216 rn_time_dmp_out = 1. ! Outflow damping time scale 217 nn_rimwidth = 10 ! width of the relaxation zone 218 ln_vol = .false. ! total volume correction (see nn_volctl parameter) 219 nn_volctl = 1 ! = 0, the total water flux across open boundaries is zero 220 nb_jpk_bdy = -1 ! number of levels in the bdy data (set < 0 if consistent with planned run) 221 / 222 !----------------------------------------------------------------------- 223 &namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") 224 !----------------------------------------------------------------------- 225 nn_nchunks_i = 4 ! number of chunks in i-dimension 226 nn_nchunks_j = 4 ! number of chunks in j-dimension 227 nn_nchunks_k = 31 ! number of chunks in k-dimension 228 ! ! setting nn_nchunks_k = jpk will give a chunk size of 1 in the vertical which 229 ! ! is optimal for postprocessing which works exclusively with horizontal slabs 230 ln_nc4zip = .true. ! (T) use netcdf4 chunking and compression 231 ! ! (F) ignore chunking information and produce netcdf3-compatible files 171 ln_chk_bathy = .FALSE. ! 172 npt_connect = 2 173 npt_copy = 2 232 174 / 233 175 !----------------------------------------------------------------------- … … 238 180 nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation 239 181 ln_nnogather = .true. ! activate code to avoid mpi_allgather use at the northfold 240 jpni = 0! jpni number of processors following i (set automatically if < 1)241 jpnj = 0! jpnj number of processors following j (set automatically if < 1)182 jpni = 1 ! jpni number of processors following i (set automatically if < 1) 183 jpnj = 1 ! jpnj number of processors following j (set automatically if < 1) 242 184 / 243 !-----------------------------------------------------------------------244 &namctl ! Control prints (default: OFF)245 !-----------------------------------------------------------------------246 ln_ctl = .FALSE. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T247 sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following248 sn_cfctl%l_runstat = .FALSE. ! switches and which areas produce reports with the proc integer settings.249 sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure250 sn_cfctl%l_oceout = .FALSE. ! that all areas report.251 sn_cfctl%l_layout = .FALSE. !252 sn_cfctl%l_mppout = .FALSE. !253 sn_cfctl%l_mpptop = .FALSE. !254 sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0]255 sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000]256 sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1]257 sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info258 nn_print = 0 ! level of print (0 no extra print)259 nn_ictls = 0 ! start i indice of control sum (use to compare mono versus260 nn_ictle = 0 ! end i indice of control sum multi processor runs261 nn_jctls = 0 ! start j indice of control over a subdomain)262 nn_jctle = 0 ! end j indice of control263 nn_isplt = 1 ! number of processors in i-direction264 nn_jsplt = 1 ! number of processors in j-direction265 ln_timing = .false. ! timing by routine write out in timing.output file266 ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii267 / -
utils/tools/DOMAINcfg/src/agrif_domzgr.F90
r12414 r13204 1 MODULE agrif_domzgr 2 3 USE agrif_profiles 4 USE dom_oce 5 6 IMPLICIT NONE 7 PRIVATE 8 9 PUBLIC :: agrif_create_bathy_meter 10 11 12 CONTAINS 13 1 14 #if defined key_agrif 2 subroutine agrif_domzgr3 end subroutine agrif_domzgr4 15 5 subroutine agrif_create_bathy_meter 6 use agrif_profiles 7 external :: init_bathy 16 SUBROUTINE agrif_create_bathy_meter 8 17 9 callAgrif_Init_variable(bathy_id, procname = init_bathy)18 CALL Agrif_Init_variable(bathy_id, procname = init_bathy) 10 19 11 end subroutineagrif_create_bathy_meter20 END SUBROUTINE agrif_create_bathy_meter 12 21 13 SUBROUTINE init_bathy( ptab, i1, i2, j1, j2, before, nb,ndir) 14 use dom_oce 22 SUBROUTINE init_bathy( ptab, i1, i2, j1, j2, before, nb,ndir) 15 23 !!---------------------------------------------------------------------- 16 24 !! *** ROUTINE interpsshn *** … … 20 28 LOGICAL , INTENT(in ) :: before 21 29 INTEGER , INTENT(in ) :: nb , ndir 22 LOGICAL :: western_side, eastern_side,northern_side,southern_side23 30 ! 24 31 !!---------------------------------------------------------------------- 25 ! 26 western_side = (nb == 1).AND.(ndir == 1) 27 eastern_side = (nb == 1).AND.(ndir == 2) 28 southern_side = (nb == 2).AND.(ndir == 1) 29 northern_side = (nb == 2).AND.(ndir == 2) 32 INTEGER :: ji,jj 33 30 34 IF( before) THEN 31 35 ptab(i1:i2,j1:j2) = bathy(i1:i2,j1:j2) 36 DO jj=j1,j2 37 DO ji=i1,i2 38 ptab(ji,jj) = SUM( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj) 39 END DO 40 END DO 32 41 ELSE 33 42 bathy(i1:i2,j1:j2)=ptab … … 35 44 ! 36 45 END SUBROUTINE init_bathy 46 37 47 #else 38 subroutine agrif_domzgr_empty 39 end subroutine agrif_domzgr_empty 48 SUBROUTINE agrif_create_bathy_meter 49 END SUBROUTINE agrif_create_bathy_meter 40 50 #endif 51 END MODULE agrif_domzgr -
utils/tools/DOMAINcfg/src/agrif_parameters.F90
r12414 r13204 1 #ifdef key_agrif 2 module agrif_parameters 3 USE par_kind1 MODULE agrif_parameters 2 3 USE par_kind 4 4 5 INTEGER :: nn_cln_update 6 LOGICAL :: ln_spc_dyn 7 REAL(wp) :: rn_sponge_tra 8 REAL(wp) :: rn_sponge_dyn 9 LOGICAL :: ln_chk_bathy 10 INTEGER :: npt_copy 11 INTEGER :: npt_connect 5 PUBLIC 12 6 13 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: ztabramp 7 #if defined key_agrif 14 8 15 end module agrif_parameters 16 #else 17 subroutine agrif_parameters_empty 18 end subroutine agrif_parameters_empty 9 INTEGER :: nn_cln_update 10 LOGICAL :: ln_spc_dyn 11 REAL(wp) :: rn_sponge_tra 12 REAL(wp) :: rn_sponge_dyn 13 LOGICAL :: ln_chk_bathy 14 INTEGER :: npt_copy 15 INTEGER :: npt_connect 16 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: ztabramp 17 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:,:) :: e3t_interp 18 19 19 #endif 20 21 END MODULE agrif_parameters -
utils/tools/DOMAINcfg/src/agrif_profiles.F90
r12414 r13204 1 moduleagrif_profiles1 MODULE agrif_profiles 2 2 3 integer :: glamt_id, glamu_id, glamv_id,glamf_id 4 integer :: gphit_id, gphiu_id, gphiv_id,gphif_id 5 integer :: e1t_id, e1u_id, e1v_id, e1f_id 6 integer :: e2t_id, e2u_id, e2v_id, e2f_id 3 PUBLIC 4 5 #if defined key_agrif 6 7 INTEGER :: glamt_id, glamu_id, glamv_id,glamf_id 8 INTEGER :: gphit_id, gphiu_id, gphiv_id,gphif_id 9 INTEGER :: e1t_id, e1u_id, e1v_id, e1f_id 10 INTEGER :: e2t_id, e2u_id, e2v_id, e2f_id 7 11 8 12 9 integer:: bathy_id13 INTEGER :: bathy_id 10 14 11 15 ! Vertical scale factors 12 16 13 integer:: e3t_id14 integer:: e3t_copy_id15 integer:: e3t_connect_id16 integer:: e3u_id, e3v_id17 INTEGER :: e3t_id 18 INTEGER :: e3t_copy_id 19 INTEGER :: e3t_connect_id 20 INTEGER :: e3u_id, e3v_id 17 21 18 22 ! Bottom level 19 integer :: bottom_level_id 20 end module agrif_profiles 23 INTEGER :: bottom_level_id 24 25 # endif 26 END MODULE agrif_profiles -
utils/tools/DOMAINcfg/src/agrif_user.F90
r12414 r13204 1 1 #if defined key_agrif 2 subroutine agrif_initworkspace() 2 SUBROUTINE agrif_user() 3 !!---------------------------------------------------------------------- 4 !! *** ROUTINE agrif_user *** 5 !!---------------------------------------------------------------------- 6 END SUBROUTINE agrif_user 7 8 SUBROUTINE agrif_initworkspace() 3 9 !!---------------------------------------------------------------------- 4 10 !! *** ROUTINE Agrif_InitWorkspace *** 5 11 !!---------------------------------------------------------------------- 6 end subroutine agrif_initworkspace 7 SUBROUTINE Agrif_InitValues 12 END SUBROUTINE agrif_initworkspace 13 14 SUBROUTINE Agrif_InitValues 8 15 !!---------------------------------------------------------------------- 9 16 !! *** ROUTINE Agrif_InitValues *** … … 11 18 !! ** Purpose :: Declaration of variables to be interpolated 12 19 !!---------------------------------------------------------------------- 13 USE Agrif_Util 14 USE dom_oce 15 USE nemogcm 16 USE domain 17 !! 18 IMPLICIT NONE 19 20 21 CALL nemo_init !* Initializations of each fine grid 22 23 CALL dom_nam 24 CALL cfg_write ! create the configuration file 25 26 END SUBROUTINE Agrif_InitValues 27 28 SUBROUTINE Agrif_InitValues_cont 29 30 use dom_oce 31 integer :: irafx, irafy 32 logical :: ln_perio 33 integer nx,ny 34 35 irafx = agrif_irhox() 36 irafy = agrif_irhoy() 37 38 nx=nlci ; ny=nlcj 20 USE Agrif_Util 21 USE dom_oce 22 USE nemogcm 23 USE domain 24 !! 25 IMPLICIT NONE 26 27 ! No temporal refinement 28 CALL Agrif_Set_coeffreft(1) 29 30 CALL nemo_init !* Initializations of each fine grid 31 32 CALL dom_nam 33 34 END SUBROUTINE Agrif_InitValues 35 36 SUBROUTINE Agrif_InitValues_cont 37 !!---------------------------------------------------------------------- 38 !! *** ROUTINE Agrif_InitValues_cont *** 39 !! 40 !! ** Purpose :: Initialisation of variables to be interpolated 41 !!---------------------------------------------------------------------- 42 USE dom_oce 43 USE lbclnk 44 !! 45 IMPLICIT NONE 46 ! 47 INTEGER :: nx, ny 48 INTEGER :: irafx, irafy 49 LOGICAL :: ln_perio 50 ! 51 irafx = agrif_irhox() 52 irafy = agrif_irhoy() 53 54 nx = nlci ; ny = nlcj 39 55 40 56 ! IF(jperio /=1 .AND. jperio/=4 .AND. jperio/=6 ) THEN … … 44 60 ! nbghostcellsfine_tot_y= nbghostcellsfine_y +1 45 61 ! ELSE 46 ! nx = (nbcellsx)+2*nbghostcellsfine_x 62 ! nx = (nbcellsx)+2*nbghostcellsfine_x 47 63 ! ny = (nbcellsy)+2*nbghostcellsfine+2 48 64 ! nbghostcellsfine_tot_x= 1 … … 53 69 ! nx = nbcellsx+irafx 54 70 ! ny = nbcellsy+irafy 55 56 WRITE(*,*) ' ' 57 WRITE(*,*)'Size of the High resolution grid: ',nx,' x ',ny 58 WRITE(*,*) ' ' 59 60 call agrif_init_lonlat() 61 ln_perio=.FALSE. 62 if( jperio ==1 .OR. jperio==2 .OR. jperio==4) ln_perio=.TRUE. 63 64 where (glamt < -180) glamt = glamt +360. 65 if (ln_perio) then 66 glamt(1,:)=glamt(nx-1,:) 67 glamt(nx,:)=glamt(2,:) 68 endif 69 70 where (glamu < -180) glamu = glamu +360. 71 if (ln_perio) then 72 glamu(1,:)=glamu(nx-1,:) 73 glamu(nx,:)=glamu(2,:) 74 endif 75 76 where (glamv < -180) glamv = glamv +360. 77 if (ln_perio) then 78 glamv(1,:)=glamv(nx-1,:) 79 glamv(nx,:)=glamv(2,:) 80 endif 81 82 where (glamf < -180) glamf = glamf +360. 83 if (ln_perio) then 84 glamf(1,:)=glamf(nx-1,:) 85 glamf(nx,:)=glamf(2,:) 86 endif 87 88 call agrif_init_scales() 89 90 91 END SUBROUTINE Agrif_InitValues_cont 92 93 94 subroutine agrif_declare_var() 95 use par_oce 96 use dom_oce 97 use agrif_profiles 98 use agrif_parameters 99 100 IMPLICIT NONE 101 102 integer :: ind1, ind2, ind3 103 integer nx,ny 104 integer nbghostcellsfine_tot_x, nbghostcellsfine_tot_y 105 INTEGER :: irafx 106 !!---------------------------------------------------------------------- 107 108 ! 1. Declaration of the type of variable which have to be interpolated 109 !--------------------------------------------------------------------- 110 nx=nlci ; ny=nlcj 111 112 !ind2 = nbghostcellsfine_tot_x + 1 113 !ind3 = nbghostcellsfine_tot_y + 1 114 ind2 = 2 + nbghostcells 115 ind3 = ind2 116 nbghostcellsfine_tot_x=nbghostcells+1 117 nbghostcellsfine_tot_y=nbghostcells+1 118 119 irafx = Agrif_irhox() 120 121 CALL agrif_nemo_init ! specific namelist part if needed 122 123 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),glamt_id) 124 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),glamu_id) 125 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),glamv_id) 126 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),glamf_id) 127 128 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),gphit_id) 129 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),gphiu_id) 130 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),gphiv_id) 131 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),gphif_id) 132 133 ! Horizontal scale factors 134 135 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e1t_id) 136 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e1u_id) 137 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e1v_id) 138 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e1f_id) 139 140 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e2t_id) 141 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e2u_id) 142 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e2v_id) 143 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e2f_id) 144 145 ! Bathymetry 146 147 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),bathy_id) 148 149 ! Vertical scale factors 150 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3t_id) 151 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3t_copy_id) 152 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk+1/),e3t_connect_id) 153 154 CALL agrif_declare_variable((/1,2,0/),(/ind2-1,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3u_id) 155 CALL agrif_declare_variable((/2,1,0/),(/ind2,ind3-1,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3v_id) 156 157 ! Bottom level 158 159 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),bottom_level_id) 160 161 CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_linear) 162 CALL Agrif_Set_interp(glamt_id,interp=AGRIF_linear) 163 CALL Agrif_Set_bc( glamt_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 164 165 CALL Agrif_Set_bcinterp(glamu_id,interp=AGRIF_linear) 166 CALL Agrif_Set_interp(glamu_id,interp=AGRIF_linear) 167 CALL Agrif_Set_bc( glamu_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 168 169 CALL Agrif_Set_bcinterp(glamv_id,interp=AGRIF_linear) 170 CALL Agrif_Set_interp(glamv_id,interp=AGRIF_linear) 171 CALL Agrif_Set_bc( glamv_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 172 173 CALL Agrif_Set_bcinterp(glamf_id,interp=AGRIF_linear) 174 CALL Agrif_Set_interp(glamf_id,interp=AGRIF_linear) 175 CALL Agrif_Set_bc( glamf_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 176 177 CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_linear) 178 CALL Agrif_Set_interp(gphit_id,interp=AGRIF_linear) 179 CALL Agrif_Set_bc( gphit_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 180 181 CALL Agrif_Set_bcinterp(gphiu_id,interp=AGRIF_linear) 182 CALL Agrif_Set_interp(gphiu_id,interp=AGRIF_linear) 183 CALL Agrif_Set_bc( gphiu_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 184 185 CALL Agrif_Set_bcinterp(gphiv_id,interp=AGRIF_linear) 186 CALL Agrif_Set_interp(gphiv_id,interp=AGRIF_linear) 187 CALL Agrif_Set_bc( gphiv_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 188 189 CALL Agrif_Set_bcinterp(gphif_id,interp=AGRIF_linear) 190 CALL Agrif_Set_interp(gphif_id,interp=AGRIF_linear) 191 CALL Agrif_Set_bc( gphif_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 192 193 ! 194 195 CALL Agrif_Set_bcinterp(e1t_id,interp=AGRIF_ppm) 196 CALL Agrif_Set_interp(e1t_id,interp=AGRIF_ppm) 197 CALL Agrif_Set_bc( e1t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 198 199 CALL Agrif_Set_bcinterp(e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 200 CALL Agrif_Set_interp(e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 201 CALL Agrif_Set_bc( e1u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 202 203 CALL Agrif_Set_bcinterp(e1v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 204 CALL Agrif_Set_interp(e1v_id, interp1=AGRIF_ppm, interp2=Agrif_linear) 205 CALL Agrif_Set_bc( e1v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 206 207 CALL Agrif_Set_bcinterp(e1f_id,interp=AGRIF_linear) 208 CALL Agrif_Set_interp(e1f_id,interp=AGRIF_linear) 209 CALL Agrif_Set_bc( e1f_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 210 211 CALL Agrif_Set_bcinterp(e2t_id,interp=AGRIF_ppm) 212 CALL Agrif_Set_interp(e2t_id,interp=AGRIF_ppm) 213 CALL Agrif_Set_bc( e2t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 214 215 CALL Agrif_Set_bcinterp(e2u_id,interp1=Agrif_linear, interp2=AGRIF_ppm) 216 CALL Agrif_Set_interp(e2u_id,interp1=Agrif_linear, interp2=AGRIF_ppm) 217 CALL Agrif_Set_bc( e2u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 218 219 CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 220 CALL Agrif_Set_interp(e2v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 221 CALL Agrif_Set_bc( e2v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 222 223 CALL Agrif_Set_bcinterp(e2f_id,interp=AGRIF_linear) 224 CALL Agrif_Set_interp(e2f_id,interp=AGRIF_linear) 225 CALL Agrif_Set_bc( e2f_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 226 227 CALL Agrif_Set_bcinterp(bathy_id,interp=AGRIF_linear) 228 CALL Agrif_Set_interp(bathy_id,interp=AGRIF_linear) 229 CALL Agrif_Set_bc( bathy_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 230 231 ! Vertical scale factors 232 CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_ppm) 233 CALL Agrif_Set_interp(e3t_id,interp=AGRIF_ppm) 234 CALL Agrif_Set_bc( e3t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 235 CALL Agrif_Set_Updatetype( e3t_id, update = AGRIF_Update_Average) 236 237 CALL Agrif_Set_bcinterp(e3t_copy_id,interp=AGRIF_constant) 238 CALL Agrif_Set_interp(e3t_copy_id,interp=AGRIF_constant) 239 CALL Agrif_Set_bc( e3t_copy_id, (/-npt_copy*irafx-1,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/)) 240 241 CALL Agrif_Set_bcinterp(e3t_connect_id,interp=AGRIF_ppm) 242 CALL Agrif_Set_interp(e3t_connect_id,interp=AGRIF_ppm) 243 CALL Agrif_Set_bc( e3t_connect_id, (/-(npt_copy+npt_connect)*irafx-1,-npt_copy*irafx-2/)) 244 245 CALL Agrif_Set_bcinterp(e3u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 246 CALL Agrif_Set_interp(e3u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 247 CALL Agrif_Set_bc( e3u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 248 CALL Agrif_Set_Updatetype(e3u_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 249 250 CALL Agrif_Set_bcinterp(e3v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 251 CALL Agrif_Set_interp(e3v_id, interp1=AGRIF_ppm, interp2=Agrif_linear) 252 CALL Agrif_Set_bc( e3v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 253 CALL Agrif_Set_Updatetype(e3v_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 254 255 ! Bottom level 256 CALL Agrif_Set_bcinterp(bottom_level_id,interp=AGRIF_constant) 257 CALL Agrif_Set_interp(bottom_level_id,interp=AGRIF_constant) 258 CALL Agrif_Set_bc( bottom_level_id, (/-npt_copy*irafx-1,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/)) 259 CALL Agrif_Set_Updatetype( bottom_level_id, update = AGRIF_Update_Max) 260 261 end subroutine agrif_declare_var 262 263 264 subroutine agrif_init_lonlat() 265 use agrif_profiles 266 use agrif_util 267 external :: init_glamt, init_glamu, init_glamv, init_glamf 268 external :: init_gphit, init_gphiu, init_gphiv, init_gphif 269 270 call Agrif_Init_variable(glamt_id, procname = init_glamt) 271 call Agrif_Init_variable(glamu_id, procname = init_glamu) 272 call Agrif_Init_variable(glamv_id, procname = init_glamv) 273 call Agrif_Init_variable(glamf_id, procname = init_glamf) 274 275 call Agrif_Init_variable(gphit_id, procname = init_gphit) 276 call Agrif_Init_variable(gphiu_id, procname = init_gphiu) 277 call Agrif_Init_variable(gphiv_id, procname = init_gphiv) 278 call Agrif_Init_variable(gphif_id, procname = init_gphif) 279 280 end subroutine agrif_init_lonlat 281 282 subroutine agrif_init_scales() 283 use agrif_profiles 284 use agrif_util 285 external :: init_e1t, init_e1u, init_e1v, init_e1f 286 external :: init_e2t, init_e2u, init_e2v, init_e2f 287 288 call Agrif_Init_variable(e1t_id, procname = init_e1t) 289 call Agrif_Init_variable(e1u_id, procname = init_e1u) 290 call Agrif_Init_variable(e1v_id, procname = init_e1v) 291 call Agrif_Init_variable(e1f_id, procname = init_e1f) 292 293 call Agrif_Init_variable(e2t_id, procname = init_e2t) 294 call Agrif_Init_variable(e2u_id, procname = init_e2u) 295 call Agrif_Init_variable(e2v_id, procname = init_e2v) 296 call Agrif_Init_variable(e2f_id, procname = init_e2f) 297 298 end subroutine agrif_init_scales 299 300 301 302 SUBROUTINE init_glamt( ptab, i1, i2, j1, j2, before, nb,ndir) 303 use dom_oce 71 72 WRITE(*,*) ' ' 73 WRITE(*,*)'Size of the High resolution grid: ',nx,' x ',ny 74 WRITE(*,*) ' ' 75 76 CALL agrif_init_lonlat() 77 ln_perio = .FALSE. 78 IF( jperio == 1 .OR. jperio == 2 .OR. jperio == 4 ) ln_perio=.TRUE. 79 80 WHERE (glamt < -180) glamt = glamt +360. 81 WHERE (glamt > +180) glamt = glamt -360. 82 83 CALL lbc_lnk( 'glamt', glamt, 'T', 1._wp) 84 CALL lbc_lnk( 'gphit', gphit, 'T', 1._wp) 85 86 WHERE (glamu < -180) glamu = glamu +360. 87 WHERE (glamu > +180) glamu = glamu -360. 88 CALL lbc_lnk( 'glamu', glamu, 'U', 1._wp) 89 CALL lbc_lnk( 'gphiu', gphiu, 'U', 1._wp) 90 91 WHERE (glamv < -180) glamv = glamv +360. 92 WHERE (glamv > +180) glamv = glamv -360. 93 CALL lbc_lnk( 'glamv', glamv, 'V', 1._wp) 94 CALL lbc_lnk( 'gphiv', gphiv, 'V', 1._wp) 95 96 WHERE (glamf < -180) glamf = glamf +360. 97 WHERE (glamf > +180) glamf = glamf -360. 98 CALL lbc_lnk( 'glamf', glamf, 'F', 1._wp) 99 CALL lbc_lnk( 'gphif', gphif, 'F', 1._wp) 100 101 ! Correct South and North 102 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 103 glamt(:,1) = glamt(:,2) 104 gphit(:,1) = gphit(:,2) 105 glamu(:,1) = glamu(:,2) 106 gphiu(:,1) = gphiu(:,2) 107 glamv(:,1) = glamv(:,2) 108 gphiv(:,1) = gphiv(:,2) 109 ENDIF 110 IF ((nbondj == 1).OR.(nbondj == 2)) THEN 111 glamt(:,jpj) = glamt(:,jpj-1) 112 gphit(:,jpj) = gphit(:,jpj-1) 113 glamu(:,jpj) = glamu(:,jpj-1) 114 gphiu(:,jpj) = gphiu(:,jpj-1) 115 glamv(:,jpj) = glamv(:,jpj-1) 116 gphiv(:,jpj) = gphiv(:,jpj-1) 117 glamf(:,jpj) = glamf(:,jpj-1) 118 gphif(:,jpj) = gphif(:,jpj-1) 119 ENDIF 120 121 ! Correct West and East 122 IF( jperio /= 1 ) THEN 123 IF((nbondi == -1) .OR. (nbondi == 2) ) THEN 124 glamt(1,:) = glamt(2,:) 125 gphit(1,:) = gphit(2,:) 126 glamu(1,:) = glamu(2,:) 127 gphiu(1,:) = gphiu(2,:) 128 glamv(1,:) = glamv(2,:) 129 gphiv(1,:) = gphiv(2,:) 130 ENDIF 131 IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 132 glamt(jpi,:) = glamt(jpi-1,:) 133 gphit(jpi,:) = gphit(jpi-1,:) 134 glamu(jpi,:) = glamu(jpi-1,:) 135 gphiu(jpi,:) = gphiu(jpi-1,:) 136 glamv(jpi,:) = glamv(jpi-1,:) 137 gphiv(jpi,:) = gphiv(jpi-1,:) 138 glamf(jpi,:) = glamf(jpi-1,:) 139 gphif(jpi,:) = gphif(jpi-1,:) 140 ENDIF 141 ENDIF 142 143 CALL agrif_init_scales() 144 145 ! Correct South and North 146 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 147 e1t(:,1) = e1t(:,2) 148 e2t(:,1) = e2t(:,2) 149 e1u(:,1) = e1u(:,2) 150 e2u(:,1) = e2u(:,2) 151 e1v(:,1) = e1v(:,2) 152 e2v(:,1) = e2v(:,2) 153 ENDIF 154 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 155 e1t(:,jpj) = e1t(:,jpj-1) 156 e2t(:,jpj) = e2t(:,jpj-1) 157 e1u(:,jpj) = e1u(:,jpj-1) 158 e2u(:,jpj) = e2u(:,jpj-1) 159 e1v(:,jpj) = e1v(:,jpj-1) 160 e2v(:,jpj) = e2v(:,jpj-1) 161 e1f(:,jpj) = e1f(:,jpj-1) 162 e2f(:,jpj) = e2f(:,jpj-1) 163 ENDIF 164 165 ! Correct West and East 166 IF( jperio /= 1 ) THEN 167 IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 168 e1t(1,:) = e1t(2,:) 169 e2t(1,:) = e2t(2,:) 170 e1u(1,:) = e1u(2,:) 171 e2u(1,:) = e2u(2,:) 172 e1v(1,:) = e1v(2,:) 173 e2v(1,:) = e2v(2,:) 174 ENDIF 175 IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 176 e1t(jpi,:) = e1t(jpi-1,:) 177 e2t(jpi,:) = e2t(jpi-1,:) 178 e1u(jpi,:) = e1u(jpi-1,:) 179 e2u(jpi,:) = e2u(jpi-1,:) 180 e1v(jpi,:) = e1v(jpi-1,:) 181 e2v(jpi,:) = e2v(jpi-1,:) 182 e1f(jpi,:) = e1f(jpi-1,:) 183 e2f(jpi,:) = e2f(jpi-1,:) 184 ENDIF 185 ENDIF 186 187 END SUBROUTINE Agrif_InitValues_cont 188 189 190 SUBROUTINE agrif_declare_var() 191 !!---------------------------------------------------------------------- 192 !! *** ROUTINE Agrif_InitValues_cont *** 193 !! 194 !! ** Purpose :: Declaration of variables to be interpolated 195 !!---------------------------------------------------------------------- 196 USE par_oce 197 USE dom_oce 198 USE agrif_profiles 199 USE agrif_parameters 200 201 IMPLICIT NONE 202 203 INTEGER :: ind1, ind2, ind3 204 INTEGER :: nx, ny 205 INTEGER ::nbghostcellsfine_tot_x, nbghostcellsfine_tot_y 206 INTEGER :: irafx 207 208 EXTERNAL :: nemo_mapping 209 210 ! 1. Declaration of the type of variable which have to be interpolated 211 !--------------------------------------------------------------------- 212 213 nx=nlci ; ny=nlcj 214 215 ind2 = 2 + nbghostcells_x 216 ind3 = 2 + nbghostcells_y_s 217 nbghostcellsfine_tot_x=nbghostcells_x+1 218 nbghostcellsfine_tot_y=max(nbghostcells_y_s,nbghostcells_y_n)+1 219 220 irafx = Agrif_irhox() 221 222 ! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries 223 ! The procnames will not be CALLed at these boundaries 224 if (jperio == 1) THEN 225 CALL Agrif_Set_NearCommonBorderX(.TRUE.) 226 CALL Agrif_Set_DistantCommonBorderX(.TRUE.) 227 endif 228 if (.not.lk_south) THEN 229 CALL Agrif_Set_NearCommonBorderY(.TRUE.) 230 endif 231 232 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),glamt_id) 233 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),glamu_id) 234 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),glamv_id) 235 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),glamf_id) 236 237 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),gphit_id) 238 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),gphiu_id) 239 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),gphiv_id) 240 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),gphif_id) 241 242 ! Horizontal scale factors 243 244 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e1t_id) 245 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e1u_id) 246 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e1v_id) 247 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e1f_id) 248 249 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e2t_id) 250 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),e2u_id) 251 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e2v_id) 252 CALL agrif_declare_variable((/1,1/),(/ind2-1,ind3-1/),(/'x','y'/),(/1,1/),(/nx,ny/),e2f_id) 253 254 ! Bathymetry 255 256 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),bathy_id) 257 258 ! Vertical scale factors 259 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3t_id) 260 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3t_copy_id) 261 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk+1/),e3t_connect_id) 262 263 CALL agrif_declare_variable((/1,2,0/),(/ind2-1,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3u_id) 264 CALL agrif_declare_variable((/2,1,0/),(/ind2,ind3-1,0/),(/'x','y','N'/),(/1,1,1/),(/nx,ny,jpk/),e3v_id) 265 266 ! Bottom level 267 268 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nx,ny/),bottom_level_id) 269 270 CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_linear) 271 CALL Agrif_Set_interp(glamt_id,interp=AGRIF_linear) 272 CALL Agrif_Set_bc( glamt_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 273 274 CALL Agrif_Set_bcinterp(glamu_id,interp=AGRIF_linear) 275 CALL Agrif_Set_interp(glamu_id,interp=AGRIF_linear) 276 CALL Agrif_Set_bc( glamu_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 277 278 CALL Agrif_Set_bcinterp(glamv_id,interp=AGRIF_linear) 279 CALL Agrif_Set_interp(glamv_id,interp=AGRIF_linear) 280 CALL Agrif_Set_bc( glamv_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 281 282 CALL Agrif_Set_bcinterp(glamf_id,interp=AGRIF_linear) 283 CALL Agrif_Set_interp(glamf_id,interp=AGRIF_linear) 284 CALL Agrif_Set_bc( glamf_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 285 286 CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_linear) 287 CALL Agrif_Set_interp(gphit_id,interp=AGRIF_linear) 288 CALL Agrif_Set_bc( gphit_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 289 290 CALL Agrif_Set_bcinterp(gphiu_id,interp=AGRIF_linear) 291 CALL Agrif_Set_interp(gphiu_id,interp=AGRIF_linear) 292 CALL Agrif_Set_bc( gphiu_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 293 294 CALL Agrif_Set_bcinterp(gphiv_id,interp=AGRIF_linear) 295 CALL Agrif_Set_interp(gphiv_id,interp=AGRIF_linear) 296 CALL Agrif_Set_bc( gphiv_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 297 298 CALL Agrif_Set_bcinterp(gphif_id,interp=AGRIF_linear) 299 CALL Agrif_Set_interp(gphif_id,interp=AGRIF_linear) 300 CALL Agrif_Set_bc( gphif_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 301 302 ! 303 304 CALL Agrif_Set_bcinterp(e1t_id,interp=AGRIF_ppm) 305 CALL Agrif_Set_interp(e1t_id,interp=AGRIF_ppm) 306 CALL Agrif_Set_bc( e1t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 307 308 CALL Agrif_Set_bcinterp(e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 309 CALL Agrif_Set_interp(e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 310 CALL Agrif_Set_bc( e1u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 311 312 CALL Agrif_Set_bcinterp(e1v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 313 CALL Agrif_Set_interp(e1v_id, interp1=AGRIF_ppm, interp2=Agrif_linear) 314 CALL Agrif_Set_bc( e1v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 315 316 CALL Agrif_Set_bcinterp(e1f_id,interp=AGRIF_linear) 317 CALL Agrif_Set_interp(e1f_id,interp=AGRIF_linear) 318 CALL Agrif_Set_bc( e1f_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 319 320 CALL Agrif_Set_bcinterp(e2t_id,interp=AGRIF_ppm) 321 CALL Agrif_Set_interp(e2t_id,interp=AGRIF_ppm) 322 CALL Agrif_Set_bc( e2t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 323 324 CALL Agrif_Set_bcinterp(e2u_id,interp1=Agrif_linear, interp2=AGRIF_ppm) 325 CALL Agrif_Set_interp(e2u_id,interp1=Agrif_linear, interp2=AGRIF_ppm) 326 CALL Agrif_Set_bc( e2u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 327 328 CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 329 CALL Agrif_Set_interp(e2v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 330 CALL Agrif_Set_bc( e2v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 331 332 CALL Agrif_Set_bcinterp(e2f_id,interp=AGRIF_linear) 333 CALL Agrif_Set_interp(e2f_id,interp=AGRIF_linear) 334 CALL Agrif_Set_bc( e2f_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)/) ) 335 336 CALL Agrif_Set_bcinterp(bathy_id,interp=AGRIF_linear) 337 CALL Agrif_Set_interp(bathy_id,interp=AGRIF_linear) 338 CALL Agrif_Set_bc( bathy_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 339 340 ! Vertical scale factors 341 CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_ppm) 342 CALL Agrif_Set_interp(e3t_id,interp=AGRIF_ppm) 343 CALL Agrif_Set_bc( e3t_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 344 CALL Agrif_Set_Updatetype( e3t_id, update = AGRIF_Update_Average) 345 346 CALL Agrif_Set_bcinterp(e3t_copy_id,interp=AGRIF_constant) 347 CALL Agrif_Set_interp(e3t_copy_id,interp=AGRIF_constant) 348 CALL Agrif_Set_bc( e3t_copy_id, (/-npt_copy*irafx,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/)) 349 350 CALL Agrif_Set_bcinterp(e3t_connect_id,interp=AGRIF_ppm) 351 CALL Agrif_Set_interp(e3t_connect_id,interp=AGRIF_ppm) 352 CALL Agrif_Set_bc( e3t_connect_id, (/-(npt_copy+npt_connect)*irafx-1,-npt_copy*irafx/)) 353 354 CALL Agrif_Set_bcinterp(e3u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 355 CALL Agrif_Set_interp(e3u_id, interp1=Agrif_linear, interp2=AGRIF_ppm) 356 CALL Agrif_Set_bc( e3u_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 357 CALL Agrif_Set_Updatetype(e3u_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 358 359 CALL Agrif_Set_bcinterp(e3v_id,interp1=AGRIF_ppm, interp2=Agrif_linear) 360 CALL Agrif_Set_interp(e3v_id, interp1=AGRIF_ppm, interp2=Agrif_linear) 361 CALL Agrif_Set_bc( e3v_id, (/0,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/) ) 362 CALL Agrif_Set_Updatetype(e3v_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 363 364 ! Bottom level 365 CALL Agrif_Set_bcinterp(bottom_level_id,interp=AGRIF_constant) 366 CALL Agrif_Set_interp(bottom_level_id,interp=AGRIF_constant) 367 CALL Agrif_Set_bc( bottom_level_id, (/-npt_copy*irafx,max(nbghostcellsfine_tot_x,nbghostcellsfine_tot_y)-1/)) 368 CALL Agrif_Set_Updatetype( bottom_level_id, update = AGRIF_Update_Max) 369 370 CALL Agrif_Set_ExternalMapping(nemo_mapping) 371 372 END SUBROUTINE agrif_declare_var 373 374 SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks) 375 USE dom_oce 376 INTEGER :: ndim 377 INTEGER :: ptx, pty 378 INTEGER,DIMENSION(ndim,2,2) :: bounds 379 INTEGER,DIMENSION(:,:,:,:),allocatable :: bounds_chunks 380 LOGICAL,DIMENSION(:),allocatable :: correction_required 381 INTEGER :: nb_chunks 382 INTEGER :: i 383 384 IF (agrif_debug_interp) THEN 385 DO i = 1, ndim 386 print *,'direction = ',i,bounds(i,1,2),bounds(i,2,2) 387 END DO 388 ENDIF 389 390 IF( bounds(2,2,2) > jpjglo ) THEN 391 IF( bounds(2,1,2) <= jpjglo ) THEN 392 nb_chunks = 2 393 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 394 ALLOCATE(correction_required(nb_chunks)) 395 DO i = 1, nb_chunks 396 bounds_chunks(i,:,:,:) = bounds 397 END DO 398 399 ! FIRST CHUNCK (for j<=jpjglo) 400 401 ! Original indices 402 bounds_chunks(1,1,1,1) = bounds(1,1,2) 403 bounds_chunks(1,1,2,1) = bounds(1,2,2) 404 bounds_chunks(1,2,1,1) = bounds(2,1,2) 405 bounds_chunks(1,2,2,1) = jpjglo 406 407 bounds_chunks(1,1,1,2) = bounds(1,1,2) 408 bounds_chunks(1,1,2,2) = bounds(1,2,2) 409 bounds_chunks(1,2,1,2) = bounds(2,1,2) 410 bounds_chunks(1,2,2,2) = jpjglo 411 412 ! Correction required or not 413 correction_required(1)=.FALSE. 414 415 ! SECOND CHUNCK (for j>jpjglo) 416 417 !Original indices 418 bounds_chunks(2,1,1,1) = bounds(1,1,2) 419 bounds_chunks(2,1,2,1) = bounds(1,2,2) 420 bounds_chunks(2,2,1,1) = jpjglo-2 421 bounds_chunks(2,2,2,1) = bounds(2,2,2) 422 423 ! Where to find them 424 ! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo)) 425 426 IF (ptx == 2) THEN ! T, V points 427 bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2 428 bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2 429 ELSE ! U, F points 430 bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1 431 bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1 432 ENDIF 433 434 IF (pty == 2) THEN ! T, U points 435 bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo) 436 bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2 -jpjglo) 437 ELSE ! V, F points 438 bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo) 439 bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2 -jpjglo) 440 ENDIF 441 442 ! Correction required or not 443 correction_required(2)=.TRUE. 444 445 ELSE 446 447 nb_chunks = 1 448 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 449 ALLOCATE(correction_required(nb_chunks)) 450 DO i=1,nb_chunks 451 bounds_chunks(i,:,:,:) = bounds 452 END DO 453 454 bounds_chunks(1,1,1,1) = bounds(1,1,2) 455 bounds_chunks(1,1,2,1) = bounds(1,2,2) 456 bounds_chunks(1,2,1,1) = bounds(2,1,2) 457 bounds_chunks(1,2,2,1) = bounds(2,2,2) 458 459 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2 460 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2 461 462 bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo) 463 bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo) 464 465 IF (ptx == 2) THEN ! T, V points 466 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2 467 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2 468 ELSE ! U, F points 469 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1 470 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1 471 ENDIF 472 473 IF (pty == 2) THEN ! T, U points 474 bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo) 475 bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo) 476 ELSE ! V, F points 477 bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo) 478 bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo) 479 ENDIF 480 481 correction_required(1)=.TRUE. 482 483 ENDIF ! bounds(2,1,2) <= jpjglo 484 485 ELSE IF (bounds(1,1,2) < 1) THEN 486 487 IF (bounds(1,2,2) > 0) THEN 488 nb_chunks = 2 489 ALLOCATE(correction_required(nb_chunks)) 490 correction_required=.FALSE. 491 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 492 DO i=1,nb_chunks 493 bounds_chunks(i,:,:,:) = bounds 494 END DO 495 496 bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2 497 bounds_chunks(1,1,2,2) = 1+jpiglo-2 498 499 bounds_chunks(1,1,1,1) = bounds(1,1,2) 500 bounds_chunks(1,1,2,1) = 1 501 502 bounds_chunks(2,1,1,2) = 2 503 bounds_chunks(2,1,2,2) = bounds(1,2,2) 504 505 bounds_chunks(2,1,1,1) = 2 506 bounds_chunks(2,1,2,1) = bounds(1,2,2) 507 ELSE 508 nb_chunks = 1 509 ALLOCATE(correction_required(nb_chunks)) 510 correction_required=.FALSE. 511 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 512 DO i=1,nb_chunks 513 bounds_chunks(i,:,:,:) = bounds 514 END DO 515 bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2 516 bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2 517 518 bounds_chunks(1,1,1,1) = bounds(1,1,2) 519 bounds_chunks(1,1,2,1) = bounds(1,2,2) 520 ENDIF 521 522 ELSE 523 524 nb_chunks=1 525 ALLOCATE(correction_required(nb_chunks)) 526 correction_required=.FALSE. 527 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 528 DO i=1,nb_chunks 529 bounds_chunks(i,:,:,:) = bounds 530 END DO 531 bounds_chunks(1,1,1,2) = bounds(1,1,2) 532 bounds_chunks(1,1,2,2) = bounds(1,2,2) 533 bounds_chunks(1,2,1,2) = bounds(2,1,2) 534 bounds_chunks(1,2,2,2) = bounds(2,2,2) 535 536 bounds_chunks(1,1,1,1) = bounds(1,1,2) 537 bounds_chunks(1,1,2,1) = bounds(1,2,2) 538 bounds_chunks(1,2,1,1) = bounds(2,1,2) 539 bounds_chunks(1,2,2,1) = bounds(2,2,2) 540 541 ENDIF 542 543 END SUBROUTINE nemo_mapping 544 545 FUNCTION agrif_external_switch_index(ptx,pty,i1,isens) 546 USE dom_oce 547 INTEGER :: ptx, pty, i1, isens 548 INTEGER :: agrif_external_switch_index 549 550 IF( isens == 1 ) THEN 551 IF( ptx == 2 ) THEN ! T, V points 552 agrif_external_switch_index = jpiglo-i1+2 553 ELSE ! U, F points 554 agrif_external_switch_index = jpiglo-i1+1 555 ENDIF 556 ELSE IF (isens ==2) THEN 557 IF (pty == 2) THEN ! T, U points 558 agrif_external_switch_index = jpjglo-2-(i1 -jpjglo) 559 ELSE ! V, F points 560 agrif_external_switch_index = jpjglo-3-(i1 -jpjglo) 561 ENDIF 562 ENDIF 563 564 END FUNCTION agrif_external_switch_index 565 566 SUBROUTINE correct_field(tab2d,i1,i2,j1,j2) 567 USE dom_oce 568 INTEGER :: i1,i2,j1,j2 569 REAL,DIMENSION(i1:i2,j1:j2) :: tab2d 570 571 INTEGER :: i,j 572 REAL,DIMENSION(i1:i2,j1:j2) :: tab2dtemp 573 574 tab2dtemp = tab2d 575 576 DO j=j1,j2 577 DO i=i1,i2 578 tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1)) 579 END DO 580 ENDDO 581 582 END SUBROUTINE correct_field 583 584 SUBROUTINE agrif_init_lonlat() 585 USE agrif_profiles 586 USE agrif_util 587 USE dom_oce 588 589 EXTERNAL :: init_glamt, init_glamu, init_glamv, init_glamf 590 EXTERNAL :: init_gphit, init_gphiu, init_gphiv, init_gphif 591 EXTERNAL :: longitude_linear_interp 592 593 INTEGER :: ji,jj,i1,i2,j1,j2 594 REAL, DIMENSION(jpi,jpj) :: tab2dtemp 595 INTEGER :: ind2,ind3 596 INTEGER :: irhox, irhoy 597 598 irhox = agrif_irhox() 599 irhoy = agrif_irhoy() 600 CALL Agrif_Set_external_linear_interp(longitude_linear_interp) 601 602 CALL Agrif_Init_variable(glamt_id, procname = init_glamt) 603 CALL Agrif_Init_variable(glamu_id, procname = init_glamu) 604 CALL Agrif_Init_variable(glamv_id, procname = init_glamv) 605 CALL Agrif_Init_variable(glamf_id, procname = init_glamf) 606 CALL Agrif_UnSet_external_linear_interp() 607 608 CALL Agrif_Init_variable(gphit_id, procname = init_gphit) 609 CALL Agrif_Init_variable(gphiu_id, procname = init_gphiu) 610 CALL Agrif_Init_variable(gphiv_id, procname = init_gphiv) 611 CALL Agrif_Init_variable(gphif_id, procname = init_gphif) 612 613 END SUBROUTINE agrif_init_lonlat 614 615 REAL FUNCTION longitude_linear_interp(x1,x2,coeff) 616 REAL :: x1, x2, coeff 617 REAL :: val_interp 618 619 IF( (x1*x2 <= -50*50) ) THEN 620 IF( x1 < 0 ) THEN 621 val_interp = coeff *(x1+360.) + (1.-coeff) *x2 622 ELSE 623 val_interp = coeff *x1 + (1.-coeff) *(x2+360.) 624 ENDIF 625 IF ((val_interp) >=180.) val_interp = val_interp - 360. 626 ELSE 627 val_interp = coeff * x1 + (1.-coeff) * x2 628 ENDIF 629 longitude_linear_interp = val_interp 630 631 END FUNCTION longitude_linear_interp 632 633 SUBROUTINE agrif_init_scales() 634 USE agrif_profiles 635 USE agrif_util 636 USE dom_oce 637 USE lbclnk 638 LOGICAL :: ln_perio 639 INTEGER nx,ny 640 641 EXTERNAL :: init_e1t, init_e1u, init_e1v, init_e1f 642 EXTERNAL :: init_e2t, init_e2u, init_e2v, init_e2f 643 644 nx = nlci ; ny = nlcj 645 646 ln_perio=.FALSE. 647 if( jperio ==1 .OR. jperio==2 .OR. jperio==4) ln_perio=.TRUE. 648 649 CALL Agrif_Init_variable(e1t_id, procname = init_e1t) 650 CALL Agrif_Init_variable(e1u_id, procname = init_e1u) 651 CALL Agrif_Init_variable(e1v_id, procname = init_e1v) 652 CALL Agrif_Init_variable(e1f_id, procname = init_e1f) 653 654 CALL Agrif_Init_variable(e2t_id, procname = init_e2t) 655 CALL Agrif_Init_variable(e2u_id, procname = init_e2u) 656 CALL Agrif_Init_variable(e2v_id, procname = init_e2v) 657 CALL Agrif_Init_variable(e2f_id, procname = init_e2f) 658 659 CALL lbc_lnk( 'e1t', e1t, 'T', 1._wp) 660 CALL lbc_lnk( 'e2t', e2t, 'T', 1._wp) 661 CALL lbc_lnk( 'e1u', e1u, 'U', 1._wp) 662 CALL lbc_lnk( 'e2u', e2u, 'U', 1._wp) 663 CALL lbc_lnk( 'e1v', e1v, 'V', 1._wp) 664 CALL lbc_lnk( 'e2v', e2v, 'V', 1._wp) 665 CALL lbc_lnk( 'e1f', e1f, 'F', 1._wp) 666 CALL lbc_lnk( 'e2f', e2f, 'F', 1._wp) 667 668 END SUBROUTINE agrif_init_scales 669 670 SUBROUTINE init_glamt( ptab, i1, i2, j1, j2, before, nb,ndir) 671 USE dom_oce 304 672 !!---------------------------------------------------------------------- 305 673 !! *** ROUTINE interpsshn *** 306 !!---------------------------------------------------------------------- 674 !!---------------------------------------------------------------------- 675 INTEGER , INTENT(in ) :: i1, i2, j1, j2 676 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 677 LOGICAL , INTENT(in ) :: before 678 INTEGER , INTENT(in ) :: nb , ndir 679 680 ! 681 !!---------------------------------------------------------------------- 682 ! 683 IF( before) THEN 684 ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2) 685 ELSE 686 glamt(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) 687 ENDIF 688 ! 689 END SUBROUTINE init_glamt 690 691 SUBROUTINE init_glamu( ptab, i1, i2, j1, j2, before, nb,ndir) 692 USE dom_oce 693 !!---------------------------------------------------------------------- 694 !! *** ROUTINE interpsshn *** 695 !!---------------------------------------------------------------------- 307 696 INTEGER , INTENT(in ) :: i1, i2, j1, j2 308 697 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab … … 311 700 LOGICAL :: western_side, eastern_side,northern_side,southern_side 312 701 ! 313 !!---------------------------------------------------------------------- 314 ! 315 western_side = (nb == 1).AND.(ndir == 1) 316 eastern_side = (nb == 1).AND.(ndir == 2) 317 southern_side = (nb == 2).AND.(ndir == 1) 318 northern_side = (nb == 2).AND.(ndir == 2) 319 IF( before) THEN 320 ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2) 321 ELSE 322 glamt(i1:i2,j1:j2)=ptab 323 ENDIF 324 ! 325 END SUBROUTINE init_glamt 326 327 SUBROUTINE init_glamu( ptab, i1, i2, j1, j2, before, nb,ndir) 328 use dom_oce 702 !!---------------------------------------------------------------------- 703 ! 704 IF( before) THEN 705 ptab(i1:i2,j1:j2) = glamu(i1:i2,j1:j2) 706 ELSE 707 glamu(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) 708 ENDIF 709 ! 710 END SUBROUTINE init_glamu 711 712 SUBROUTINE init_glamv( ptab, i1, i2, j1, j2, before, nb,ndir) 713 USE dom_oce 329 714 !!---------------------------------------------------------------------- 330 715 !! *** ROUTINE interpsshn *** 331 !!---------------------------------------------------------------------- 332 INTEGER , INTENT(in ) :: i1, i2, j1, j2 333 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 334 LOGICAL , INTENT(in ) :: before 335 INTEGER , INTENT(in ) :: nb , ndir 336 LOGICAL :: western_side, eastern_side,northern_side,southern_side 337 ! 338 !!---------------------------------------------------------------------- 339 ! 340 western_side = (nb == 1).AND.(ndir == 1) 341 eastern_side = (nb == 1).AND.(ndir == 2) 342 southern_side = (nb == 2).AND.(ndir == 1) 343 northern_side = (nb == 2).AND.(ndir == 2) 344 IF( before) THEN 345 ptab(i1:i2,j1:j2) = glamu(i1:i2,j1:j2) 346 ELSE 347 glamu(i1:i2,j1:j2)=ptab 348 ENDIF 349 ! 350 END SUBROUTINE init_glamu 351 352 SUBROUTINE init_glamv( ptab, i1, i2, j1, j2, before, nb,ndir) 353 use dom_oce 716 !!---------------------------------------------------------------------- 717 INTEGER , INTENT(in ) :: i1, i2, j1, j2 718 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 719 LOGICAL , INTENT(in ) :: before 720 INTEGER , INTENT(in ) :: nb , ndir 721 ! 722 !!---------------------------------------------------------------------- 723 ! 724 IF( before) THEN 725 ptab(i1:i2,j1:j2) = glamv(i1:i2,j1:j2) 726 ELSE 727 glamv(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) 728 ENDIF 729 ! 730 END SUBROUTINE init_glamv 731 732 SUBROUTINE init_glamf( ptab, i1, i2, j1, j2, before, nb,ndir) 733 USE dom_oce 734 !!---------------------------------------------------------------------- 735 !! *** ROUTINE init_glamf *** 736 !!---------------------------------------------------------------------- 737 INTEGER , INTENT(in ) :: i1, i2, j1, j2 738 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 739 LOGICAL , INTENT(in ) :: before 740 INTEGER , INTENT(in ) :: nb , ndir 741 ! 742 !!---------------------------------------------------------------------- 743 ! 744 IF( before) THEN 745 ptab(i1:i2,j1:j2) = glamf(i1:i2,j1:j2) 746 ELSE 747 glamf(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) 748 ENDIF 749 ! 750 END SUBROUTINE init_glamf 751 752 SUBROUTINE init_gphit( ptab, i1, i2, j1, j2, before, nb,ndir) 753 USE dom_oce 754 !!---------------------------------------------------------------------- 755 !! *** ROUTINE init_gphit *** 756 !!---------------------------------------------------------------------- 757 INTEGER , INTENT(in ) :: i1, i2, j1, j2 758 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 759 LOGICAL , INTENT(in ) :: before 760 INTEGER , INTENT(in ) :: nb , ndir 761 ! 762 !!---------------------------------------------------------------------- 763 ! 764 IF( before) THEN 765 ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2) 766 ELSE 767 gphit(i1:i2,j1:j2)=ptab 768 ENDIF 769 ! 770 END SUBROUTINE init_gphit 771 772 SUBROUTINE init_gphiu( ptab, i1, i2, j1, j2, before, nb,ndir) 773 USE dom_oce 774 !!---------------------------------------------------------------------- 775 !! *** ROUTINE init_gphiu *** 776 !!---------------------------------------------------------------------- 777 INTEGER , INTENT(in ) :: i1, i2, j1, j2 778 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 779 LOGICAL , INTENT(in ) :: before 780 INTEGER , INTENT(in ) :: nb , ndir 781 ! 782 !!---------------------------------------------------------------------- 783 ! 784 IF( before) THEN 785 ptab(i1:i2,j1:j2) = gphiu(i1:i2,j1:j2) 786 ELSE 787 gphiu(i1:i2,j1:j2)=ptab 788 ENDIF 789 ! 790 END SUBROUTINE init_gphiu 791 792 SUBROUTINE init_gphiv( ptab, i1, i2, j1, j2, before, nb,ndir) 793 USE dom_oce 794 !!---------------------------------------------------------------------- 795 !! *** ROUTINE init_gphiv *** 796 !!---------------------------------------------------------------------- 797 INTEGER , INTENT(in ) :: i1, i2, j1, j2 798 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 799 LOGICAL , INTENT(in ) :: before 800 INTEGER , INTENT(in ) :: nb , ndir 801 ! 802 !!---------------------------------------------------------------------- 803 804 IF( before) THEN 805 ptab(i1:i2,j1:j2) = gphiv(i1:i2,j1:j2) 806 ELSE 807 gphiv(i1:i2,j1:j2)=ptab 808 ENDIF 809 ! 810 END SUBROUTINE init_gphiv 811 812 813 SUBROUTINE init_gphif( ptab, i1, i2, j1, j2, before, nb,ndir) 814 USE dom_oce 815 !!---------------------------------------------------------------------- 816 !! *** ROUTINE init_gphif *** 817 !!---------------------------------------------------------------------- 818 INTEGER , INTENT(in ) :: i1, i2, j1, j2 819 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 820 LOGICAL , INTENT(in ) :: before 821 INTEGER , INTENT(in ) :: nb , ndir 822 ! 823 !!---------------------------------------------------------------------- 824 ! 825 IF( before) THEN 826 ptab(i1:i2,j1:j2) = gphif(i1:i2,j1:j2) 827 ELSE 828 gphif(i1:i2,j1:j2)=ptab 829 ENDIF 830 ! 831 END SUBROUTINE init_gphif 832 833 834 SUBROUTINE init_e1t( ptab, i1, i2, j1, j2, before, nb,ndir) 835 USE dom_oce 836 USE agrif_parameters 837 !!---------------------------------------------------------------------- 838 !! *** ROUTINE init_e1t *** 839 !!---------------------------------------------------------------------- 840 INTEGER , INTENT(in ) :: i1, i2, j1, j2 841 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 842 LOGICAL , INTENT(in ) :: before 843 INTEGER , INTENT(in ) :: nb , ndir 844 ! 845 !!---------------------------------------------------------------------- 846 ! 847 INTEGER :: jj 848 849 IF( before) THEN 850 ! May need to extend at south boundary 851 IF (j1<1) THEN 852 IF (.NOT.agrif_child(lk_south)) THEN 853 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 854 DO jj=1,j2 855 ptab(i1:i2,jj)=e1t(i1:i2,jj) 856 ENDDO 857 DO jj=j1,0 858 ptab(i1:i2,jj)=e1t(i1:i2,1) 859 ENDDO 860 ENDIF 861 ELSE 862 stop "OUT OF BOUNDS" 863 ENDIF 864 ELSE 865 ptab(i1:i2,j1:j2) = e1t(i1:i2,j1:j2) 866 ENDIF 867 ELSE 868 e1t(i1:i2,j1:j2)=ptab/Agrif_rhoy() 869 ENDIF 870 ! 871 END SUBROUTINE init_e1t 872 873 SUBROUTINE init_e1u( ptab, i1, i2, j1, j2, before, nb,ndir) 874 USE dom_oce 875 USE agrif_parameters 876 !!---------------------------------------------------------------------- 877 !! *** ROUTINE init_e1u *** 878 !!---------------------------------------------------------------------- 879 INTEGER , INTENT(in ) :: i1, i2, j1, j2 880 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 881 LOGICAL , INTENT(in ) :: before 882 INTEGER , INTENT(in ) :: nb , ndir 883 ! 884 !!---------------------------------------------------------------------- 885 ! 886 INTEGER :: jj 887 888 IF( before) THEN 889 IF (j1<1) THEN 890 IF (.NOT.agrif_child(lk_south)) THEN 891 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 892 DO jj=1,j2 893 ptab(i1:i2,jj)=e1u(i1:i2,jj) 894 ENDDO 895 DO jj=j1,0 896 ptab(i1:i2,jj)=e1u(i1:i2,1) 897 ENDDO 898 ENDIF 899 ELSE 900 stop "OUT OF BOUNDS" 901 ENDIF 902 ELSE 903 ptab(i1:i2,j1:j2) = e1u(i1:i2,j1:j2) 904 ENDIF 905 ELSE 906 e1u(i1:i2,j1:j2)=ptab/Agrif_rhoy() 907 ENDIF 908 ! 909 END SUBROUTINE init_e1u 910 911 SUBROUTINE init_e1v( ptab, i1, i2, j1, j2, before, nb,ndir) 912 USE dom_oce 913 !!---------------------------------------------------------------------- 914 !! *** ROUTINE init_e1v *** 915 !!---------------------------------------------------------------------- 916 INTEGER , INTENT(in ) :: i1, i2, j1, j2 917 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 918 LOGICAL , INTENT(in ) :: before 919 INTEGER , INTENT(in ) :: nb , ndir 920 ! 921 !!---------------------------------------------------------------------- 922 ! 923 IF( before) THEN 924 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) 925 ELSE 926 e1v(i1:i2,j1:j2)=ptab/Agrif_rhoy() 927 ENDIF 928 ! 929 END SUBROUTINE init_e1v 930 931 SUBROUTINE init_e1f( ptab, i1, i2, j1, j2, before, nb,ndir) 932 USE dom_oce 933 !!---------------------------------------------------------------------- 934 !! *** ROUTINE init_e1f *** 935 !!---------------------------------------------------------------------- 936 INTEGER , INTENT(in ) :: i1, i2, j1, j2 937 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 938 LOGICAL , INTENT(in ) :: before 939 INTEGER , INTENT(in ) :: nb , ndir 940 ! 941 !!---------------------------------------------------------------------- 942 ! 943 IF( before) THEN 944 ptab(i1:i2,j1:j2) = e1f(i1:i2,j1:j2) 945 ELSE 946 e1f(i1:i2,j1:j2)=ptab/Agrif_rhoy() 947 ENDIF 948 ! 949 END SUBROUTINE init_e1f 950 951 SUBROUTINE init_e2t( ptab, i1, i2, j1, j2, before, nb,ndir) 952 USE dom_oce 953 USE agrif_parameters 954 !!---------------------------------------------------------------------- 955 !! *** ROUTINE init_e2t *** 956 !!---------------------------------------------------------------------- 957 INTEGER , INTENT(in ) :: i1, i2, j1, j2 958 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 959 LOGICAL , INTENT(in ) :: before 960 INTEGER , INTENT(in ) :: nb , ndir 961 ! 962 !!---------------------------------------------------------------------- 963 ! 964 INTEGER :: jj 965 966 IF( before) THEN 967 IF (j1<1) THEN 968 IF (.NOT.agrif_child(lk_south)) THEN 969 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 970 DO jj=1,j2 971 ptab(i1:i2,jj)=e2t(i1:i2,jj) 972 ENDDO 973 DO jj=j1,0 974 ptab(i1:i2,jj)=e2t(i1:i2,1) 975 ENDDO 976 ENDIF 977 ELSE 978 stop "OUT OF BOUNDS" 979 ENDIF 980 ELSE 981 ptab(i1:i2,j1:j2) = e2t(i1:i2,j1:j2) 982 ENDIF 983 ELSE 984 e2t(i1:i2,j1:j2)=ptab/Agrif_rhoy() 985 ENDIF 986 ! 987 END SUBROUTINE init_e2t 988 989 SUBROUTINE init_e2u( ptab, i1, i2, j1, j2, before, nb,ndir) 990 USE dom_oce 991 USE agrif_parameters 354 992 !!---------------------------------------------------------------------- 355 993 !! *** ROUTINE interpsshn *** 356 !!---------------------------------------------------------------------- 357 INTEGER , INTENT(in ) :: i1, i2, j1, j2 358 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 359 LOGICAL , INTENT(in ) :: before 360 INTEGER , INTENT(in ) :: nb , ndir 361 LOGICAL :: western_side, eastern_side,northern_side,southern_side 362 ! 363 !!---------------------------------------------------------------------- 364 ! 365 western_side = (nb == 1).AND.(ndir == 1) 366 eastern_side = (nb == 1).AND.(ndir == 2) 367 southern_side = (nb == 2).AND.(ndir == 1) 368 northern_side = (nb == 2).AND.(ndir == 2) 369 IF( before) THEN 370 ptab(i1:i2,j1:j2) = glamv(i1:i2,j1:j2) 371 ELSE 372 glamv(i1:i2,j1:j2)=ptab 373 ENDIF 374 ! 375 END SUBROUTINE init_glamv 376 377 SUBROUTINE init_glamf( ptab, i1, i2, j1, j2, before, nb,ndir) 378 use dom_oce 994 !!---------------------------------------------------------------------- 995 INTEGER , INTENT(in ) :: i1, i2, j1, j2 996 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 997 LOGICAL , INTENT(in ) :: before 998 INTEGER , INTENT(in ) :: nb , ndir 999 ! 1000 !!---------------------------------------------------------------------- 1001 ! 1002 INTEGER :: jj 1003 1004 IF( before) THEN 1005 IF (j1<1) THEN 1006 IF (.NOT.agrif_child(lk_south)) THEN 1007 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 1008 DO jj=1,j2 1009 ptab(i1:i2,jj)=e2u(i1:i2,jj) 1010 ENDDO 1011 DO jj=j1,0 1012 ptab(i1:i2,jj)=e2u(i1:i2,1) 1013 ENDDO 1014 ENDIF 1015 ELSE 1016 stop "OUT OF BOUNDS" 1017 ENDIF 1018 ELSE 1019 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) 1020 ENDIF 1021 ELSE 1022 e2u(i1:i2,j1:j2)=ptab/Agrif_rhoy() 1023 ENDIF 1024 ! 1025 END SUBROUTINE init_e2u 1026 1027 SUBROUTINE init_e2v( ptab, i1, i2, j1, j2, before, nb,ndir) 1028 USE dom_oce 379 1029 !!---------------------------------------------------------------------- 380 1030 !! *** ROUTINE interpsshn *** 381 !!---------------------------------------------------------------------- 382 INTEGER , INTENT(in ) :: i1, i2, j1, j2 383 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 384 LOGICAL , INTENT(in ) :: before 385 INTEGER , INTENT(in ) :: nb , ndir 386 LOGICAL :: western_side, eastern_side,northern_side,southern_side 387 ! 388 !!---------------------------------------------------------------------- 389 ! 390 western_side = (nb == 1).AND.(ndir == 1) 391 eastern_side = (nb == 1).AND.(ndir == 2) 392 southern_side = (nb == 2).AND.(ndir == 1) 393 northern_side = (nb == 2).AND.(ndir == 2) 394 IF( before) THEN 395 ptab(i1:i2,j1:j2) = glamf(i1:i2,j1:j2) 396 ELSE 397 glamf(i1:i2,j1:j2)=ptab 398 ENDIF 399 ! 400 END SUBROUTINE init_glamf 401 402 SUBROUTINE init_gphit( ptab, i1, i2, j1, j2, before, nb,ndir) 403 use dom_oce 1031 !!---------------------------------------------------------------------- 1032 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1033 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1034 LOGICAL , INTENT(in ) :: before 1035 INTEGER , INTENT(in ) :: nb , ndir 1036 ! 1037 !!---------------------------------------------------------------------- 1038 IF( before) THEN 1039 ptab(i1:i2,j1:j2) = e2v(i1:i2,j1:j2) 1040 ELSE 1041 e2v(i1:i2,j1:j2)=ptab/Agrif_rhoy() 1042 ENDIF 1043 ! 1044 END SUBROUTINE init_e2v 1045 1046 SUBROUTINE init_e2f( ptab, i1, i2, j1, j2, before, nb,ndir) 1047 USE dom_oce 404 1048 !!---------------------------------------------------------------------- 405 1049 !! *** ROUTINE interpsshn *** 406 !!---------------------------------------------------------------------- 407 INTEGER , INTENT(in ) :: i1, i2, j1, j2 408 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 409 LOGICAL , INTENT(in ) :: before 410 INTEGER , INTENT(in ) :: nb , ndir 411 LOGICAL :: western_side, eastern_side,northern_side,southern_side 412 ! 413 !!---------------------------------------------------------------------- 414 ! 415 western_side = (nb == 1).AND.(ndir == 1) 416 eastern_side = (nb == 1).AND.(ndir == 2) 417 southern_side = (nb == 2).AND.(ndir == 1) 418 northern_side = (nb == 2).AND.(ndir == 2) 419 IF( before) THEN 420 ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2) 421 ELSE 422 gphit(i1:i2,j1:j2)=ptab 423 ENDIF 424 ! 425 END SUBROUTINE init_gphit 426 427 SUBROUTINE init_gphiu( ptab, i1, i2, j1, j2, before, nb,ndir) 428 use dom_oce 429 !!---------------------------------------------------------------------- 430 !! *** ROUTINE interpsshn *** 431 !!---------------------------------------------------------------------- 432 INTEGER , INTENT(in ) :: i1, i2, j1, j2 433 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 434 LOGICAL , INTENT(in ) :: before 435 INTEGER , INTENT(in ) :: nb , ndir 436 LOGICAL :: western_side, eastern_side,northern_side,southern_side 437 ! 438 !!---------------------------------------------------------------------- 439 ! 440 western_side = (nb == 1).AND.(ndir == 1) 441 eastern_side = (nb == 1).AND.(ndir == 2) 442 southern_side = (nb == 2).AND.(ndir == 1) 443 northern_side = (nb == 2).AND.(ndir == 2) 444 IF( before) THEN 445 ptab(i1:i2,j1:j2) = gphiu(i1:i2,j1:j2) 446 ELSE 447 gphiu(i1:i2,j1:j2)=ptab 448 ENDIF 449 ! 450 END SUBROUTINE init_gphiu 451 452 SUBROUTINE init_gphiv( ptab, i1, i2, j1, j2, before, nb,ndir) 453 use dom_oce 454 !!---------------------------------------------------------------------- 455 !! *** ROUTINE interpsshn *** 456 !!---------------------------------------------------------------------- 457 INTEGER , INTENT(in ) :: i1, i2, j1, j2 458 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 459 LOGICAL , INTENT(in ) :: before 460 INTEGER , INTENT(in ) :: nb , ndir 461 LOGICAL :: western_side, eastern_side,northern_side,southern_side 462 ! 463 !!---------------------------------------------------------------------- 464 ! 465 western_side = (nb == 1).AND.(ndir == 1) 466 eastern_side = (nb == 1).AND.(ndir == 2) 467 southern_side = (nb == 2).AND.(ndir == 1) 468 northern_side = (nb == 2).AND.(ndir == 2) 469 IF( before) THEN 470 ptab(i1:i2,j1:j2) = gphiv(i1:i2,j1:j2) 471 ELSE 472 gphiv(i1:i2,j1:j2)=ptab 473 ENDIF 474 ! 475 END SUBROUTINE init_gphiv 476 477 478 SUBROUTINE init_gphif( ptab, i1, i2, j1, j2, before, nb,ndir) 479 use dom_oce 480 !!---------------------------------------------------------------------- 481 !! *** ROUTINE interpsshn *** 482 !!---------------------------------------------------------------------- 483 INTEGER , INTENT(in ) :: i1, i2, j1, j2 484 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 485 LOGICAL , INTENT(in ) :: before 486 INTEGER , INTENT(in ) :: nb , ndir 487 LOGICAL :: western_side, eastern_side,northern_side,southern_side 488 ! 489 !!---------------------------------------------------------------------- 490 ! 491 western_side = (nb == 1).AND.(ndir == 1) 492 eastern_side = (nb == 1).AND.(ndir == 2) 493 southern_side = (nb == 2).AND.(ndir == 1) 494 northern_side = (nb == 2).AND.(ndir == 2) 495 IF( before) THEN 496 ptab(i1:i2,j1:j2) = gphif(i1:i2,j1:j2) 497 ELSE 498 gphif(i1:i2,j1:j2)=ptab 499 ENDIF 500 ! 501 END SUBROUTINE init_gphif 502 503 504 SUBROUTINE init_e1t( ptab, i1, i2, j1, j2, before, nb,ndir) 505 use dom_oce 506 !!---------------------------------------------------------------------- 507 !! *** ROUTINE interpsshn *** 508 !!---------------------------------------------------------------------- 509 INTEGER , INTENT(in ) :: i1, i2, j1, j2 510 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 511 LOGICAL , INTENT(in ) :: before 512 INTEGER , INTENT(in ) :: nb , ndir 513 LOGICAL :: western_side, eastern_side,northern_side,southern_side 514 ! 515 !!---------------------------------------------------------------------- 516 ! 517 western_side = (nb == 1).AND.(ndir == 1) 518 eastern_side = (nb == 1).AND.(ndir == 2) 519 southern_side = (nb == 2).AND.(ndir == 1) 520 northern_side = (nb == 2).AND.(ndir == 2) 521 IF( before) THEN 522 ptab(i1:i2,j1:j2) = e1t(i1:i2,j1:j2) 523 ELSE 524 e1t(i1:i2,j1:j2)=ptab/Agrif_rhoy() 525 ENDIF 526 ! 527 END SUBROUTINE init_e1t 528 529 SUBROUTINE init_e1u( ptab, i1, i2, j1, j2, before, nb,ndir) 530 use dom_oce 531 !!---------------------------------------------------------------------- 532 !! *** ROUTINE interpsshn *** 533 !!---------------------------------------------------------------------- 534 INTEGER , INTENT(in ) :: i1, i2, j1, j2 535 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 536 LOGICAL , INTENT(in ) :: before 537 INTEGER , INTENT(in ) :: nb , ndir 538 LOGICAL :: western_side, eastern_side,northern_side,southern_side 539 ! 540 !!---------------------------------------------------------------------- 541 ! 542 western_side = (nb == 1).AND.(ndir == 1) 543 eastern_side = (nb == 1).AND.(ndir == 2) 544 southern_side = (nb == 2).AND.(ndir == 1) 545 northern_side = (nb == 2).AND.(ndir == 2) 546 IF( before) THEN 547 ptab(i1:i2,j1:j2) = e1u(i1:i2,j1:j2) 548 ELSE 549 e1u(i1:i2,j1:j2)=ptab/Agrif_rhoy() 550 ENDIF 551 ! 552 END SUBROUTINE init_e1u 553 554 SUBROUTINE init_e1v( ptab, i1, i2, j1, j2, before, nb,ndir) 555 use dom_oce 556 !!---------------------------------------------------------------------- 557 !! *** ROUTINE interpsshn *** 558 !!---------------------------------------------------------------------- 559 INTEGER , INTENT(in ) :: i1, i2, j1, j2 560 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 561 LOGICAL , INTENT(in ) :: before 562 INTEGER , INTENT(in ) :: nb , ndir 563 LOGICAL :: western_side, eastern_side,northern_side,southern_side 564 ! 565 !!---------------------------------------------------------------------- 566 ! 567 western_side = (nb == 1).AND.(ndir == 1) 568 eastern_side = (nb == 1).AND.(ndir == 2) 569 southern_side = (nb == 2).AND.(ndir == 1) 570 northern_side = (nb == 2).AND.(ndir == 2) 571 IF( before) THEN 572 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) 573 ELSE 574 e1v(i1:i2,j1:j2)=ptab/Agrif_rhoy() 575 ENDIF 576 ! 577 END SUBROUTINE init_e1v 578 579 SUBROUTINE init_e1f( ptab, i1, i2, j1, j2, before, nb,ndir) 580 use dom_oce 581 !!---------------------------------------------------------------------- 582 !! *** ROUTINE interpsshn *** 583 !!---------------------------------------------------------------------- 584 INTEGER , INTENT(in ) :: i1, i2, j1, j2 585 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 586 LOGICAL , INTENT(in ) :: before 587 INTEGER , INTENT(in ) :: nb , ndir 588 LOGICAL :: western_side, eastern_side,northern_side,southern_side 589 ! 590 !!---------------------------------------------------------------------- 591 ! 592 western_side = (nb == 1).AND.(ndir == 1) 593 eastern_side = (nb == 1).AND.(ndir == 2) 594 southern_side = (nb == 2).AND.(ndir == 1) 595 northern_side = (nb == 2).AND.(ndir == 2) 596 IF( before) THEN 597 ptab(i1:i2,j1:j2) = e1f(i1:i2,j1:j2) 598 ELSE 599 e1f(i1:i2,j1:j2)=ptab/Agrif_rhoy() 600 ENDIF 601 ! 602 END SUBROUTINE init_e1f 603 604 SUBROUTINE init_e2t( ptab, i1, i2, j1, j2, before, nb,ndir) 605 use dom_oce 606 !!---------------------------------------------------------------------- 607 !! *** ROUTINE interpsshn *** 608 !!---------------------------------------------------------------------- 609 INTEGER , INTENT(in ) :: i1, i2, j1, j2 610 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 611 LOGICAL , INTENT(in ) :: before 612 INTEGER , INTENT(in ) :: nb , ndir 613 LOGICAL :: western_side, eastern_side,northern_side,southern_side 614 ! 615 !!---------------------------------------------------------------------- 616 ! 617 western_side = (nb == 1).AND.(ndir == 1) 618 eastern_side = (nb == 1).AND.(ndir == 2) 619 southern_side = (nb == 2).AND.(ndir == 1) 620 northern_side = (nb == 2).AND.(ndir == 2) 621 IF( before) THEN 622 ptab(i1:i2,j1:j2) = e2t(i1:i2,j1:j2) 623 ELSE 624 e2t(i1:i2,j1:j2)=ptab/Agrif_rhoy() 625 ENDIF 626 ! 627 END SUBROUTINE init_e2t 628 629 SUBROUTINE init_e2u( ptab, i1, i2, j1, j2, before, nb,ndir) 630 use dom_oce 631 !!---------------------------------------------------------------------- 632 !! *** ROUTINE interpsshn *** 633 !!---------------------------------------------------------------------- 634 INTEGER , INTENT(in ) :: i1, i2, j1, j2 635 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 636 LOGICAL , INTENT(in ) :: before 637 INTEGER , INTENT(in ) :: nb , ndir 638 LOGICAL :: western_side, eastern_side,northern_side,southern_side 639 ! 640 !!---------------------------------------------------------------------- 641 ! 642 western_side = (nb == 1).AND.(ndir == 1) 643 eastern_side = (nb == 1).AND.(ndir == 2) 644 southern_side = (nb == 2).AND.(ndir == 1) 645 northern_side = (nb == 2).AND.(ndir == 2) 646 IF( before) THEN 647 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) 648 ELSE 649 e2u(i1:i2,j1:j2)=ptab/Agrif_rhoy() 650 ENDIF 651 ! 652 END SUBROUTINE init_e2u 653 654 SUBROUTINE init_e2v( ptab, i1, i2, j1, j2, before, nb,ndir) 655 use dom_oce 656 !!---------------------------------------------------------------------- 657 !! *** ROUTINE interpsshn *** 658 !!---------------------------------------------------------------------- 659 INTEGER , INTENT(in ) :: i1, i2, j1, j2 660 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 661 LOGICAL , INTENT(in ) :: before 662 INTEGER , INTENT(in ) :: nb , ndir 663 LOGICAL :: western_side, eastern_side,northern_side,southern_side 664 ! 665 !!---------------------------------------------------------------------- 666 ! 667 western_side = (nb == 1).AND.(ndir == 1) 668 eastern_side = (nb == 1).AND.(ndir == 2) 669 southern_side = (nb == 2).AND.(ndir == 1) 670 northern_side = (nb == 2).AND.(ndir == 2) 671 IF( before) THEN 672 ptab(i1:i2,j1:j2) = e2v(i1:i2,j1:j2) 673 ELSE 674 e2v(i1:i2,j1:j2)=ptab/Agrif_rhoy() 675 ENDIF 676 ! 677 END SUBROUTINE init_e2v 678 679 SUBROUTINE init_e2f( ptab, i1, i2, j1, j2, before, nb,ndir) 680 use dom_oce 681 !!---------------------------------------------------------------------- 682 !! *** ROUTINE interpsshn *** 683 !!---------------------------------------------------------------------- 684 INTEGER , INTENT(in ) :: i1, i2, j1, j2 685 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 686 LOGICAL , INTENT(in ) :: before 687 INTEGER , INTENT(in ) :: nb , ndir 688 LOGICAL :: western_side, eastern_side,northern_side,southern_side 689 ! 690 !!---------------------------------------------------------------------- 691 ! 692 western_side = (nb == 1).AND.(ndir == 1) 693 eastern_side = (nb == 1).AND.(ndir == 2) 694 southern_side = (nb == 2).AND.(ndir == 1) 695 northern_side = (nb == 2).AND.(ndir == 2) 1050 !!---------------------------------------------------------------------- 1051 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1052 REAL, DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1053 LOGICAL , INTENT(in ) :: before 1054 INTEGER , INTENT(in ) :: nb , ndir 1055 ! 1056 !!---------------------------------------------------------------------- 1057 ! 696 1058 IF( before) THEN 697 1059 ptab(i1:i2,j1:j2) = e2f(i1:i2,j1:j2) … … 703 1065 704 1066 705 SUBROUTINE agrif_nemo_init706 USE agrif_parameters707 USE in_out_manager 708 USE lib_mpp 709 710 711 !!712 IMPLICIT NONE 713 714 INTEGER :: ios 715 716 NAMELIST/namagrif/ nn_cln_update,ln_spc_dyn,rn_sponge_tra,rn_sponge_dyn,ln_chk_bathy,npt_connect,npt_copy1067 SUBROUTINE agrif_nemo_init 1068 USE agrif_parameters 1069 USE dom_oce 1070 USE in_out_manager 1071 USE lib_mpp 1072 !! 1073 IMPLICIT NONE 1074 1075 INTEGER :: ios 1076 1077 NAMELIST/namagrif/ nn_cln_update,ln_spc_dyn,rn_sponge_tra,rn_sponge_dyn,ln_chk_bathy,npt_connect, & 1078 & npt_copy 717 1079 718 1080 REWIND( numnam_ref ) ! Namelist namagrif in reference namelist : nesting parameters … … 730 1092 WRITE(numout,*) '~~~~~~~' 731 1093 WRITE(numout,*) ' Namelist namagrif : set nesting parameters' 732 WRITE(numout,*) ' npt_copy = ', npt_copy 733 WRITE(numout,*) ' npt_connect = ', npt_connect 734 ENDIF 735 736 END SUBROUTINE agrif_nemo_init 737 738 739 SUBROUTINE Agrif_detect( kg, ksizex ) 1094 WRITE(numout,*) ' npt_copy = ', npt_copy 1095 WRITE(numout,*) ' npt_connect = ', npt_connect 1096 ENDIF 1097 1098 ! Set the number of ghost cells according to periodicity 1099 1100 nbghostcells_x = nbghostcells 1101 nbghostcells_y_s = nbghostcells 1102 nbghostcells_y_n = nbghostcells 1103 1104 lk_west = .NOT. ( Agrif_Ix() == 1 ) 1105 lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(jpiglo) -1 ) 1106 lk_south = .NOT. ( Agrif_Iy() == 1 ) 1107 lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(jpjglo) -1 ) 1108 1109 IF (.not.agrif_root()) THEN 1110 IF (jperio == 1) THEN 1111 nbghostcells_x = 0 1112 ENDIF 1113 IF (.NOT.lk_south) THEN 1114 nbghostcells_y_s = 0 1115 ENDIF 1116 ENDIF 1117 1118 END SUBROUTINE agrif_nemo_init 1119 1120 SUBROUTINE Agrif_detect( kg, ksizex ) 740 1121 !!---------------------------------------------------------------------- 741 1122 !! *** ROUTINE Agrif_detect *** 742 1123 !!---------------------------------------------------------------------- 743 INTEGER, DIMENSION(2) :: ksizex 744 INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg 745 !!---------------------------------------------------------------------- 746 ! 747 RETURN 748 ! 749 END SUBROUTINE Agrif_detect 750 SUBROUTINE agrif_before_regridding 751 END SUBROUTINE agrif_before_regridding 752 753 SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 754 !!---------------------------------------------------------------------- 755 !! *** ROUTINE Agrif_InvLoc *** 756 !!---------------------------------------------------------------------- 757 USE dom_oce 758 !! 759 IMPLICIT NONE 760 ! 761 INTEGER :: indglob, indloc, nprocloc, i 762 !!---------------------------------------------------------------------- 763 ! 764 SELECT CASE( i ) 765 CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1 766 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 767 CASE DEFAULT 768 indglob = indloc 769 END SELECT 770 ! 771 END SUBROUTINE Agrif_InvLoc 772 773 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 1124 INTEGER, DIMENSION(2) :: ksizex 1125 INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg 1126 !!---------------------------------------------------------------------- 1127 ! 1128 RETURN 1129 ! 1130 END SUBROUTINE Agrif_detect 1131 1132 SUBROUTINE agrif_before_regridding 1133 END SUBROUTINE agrif_before_regridding 1134 1135 # if defined key_mpp_mpi 1136 SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 1137 !!---------------------------------------------------------------------- 1138 !! *** ROUTINE Agrif_InvLoc *** 1139 !!---------------------------------------------------------------------- 1140 USE dom_oce 1141 !! 1142 IMPLICIT NONE 1143 ! 1144 INTEGER :: indglob, indloc, nprocloc, i 1145 !!---------------------------------------------------------------------- 1146 ! 1147 SELECT CASE( i ) 1148 CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1 1149 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 1150 CASE DEFAULT 1151 indglob = indloc 1152 END SELECT 1153 ! 1154 END SUBROUTINE Agrif_InvLoc 1155 1156 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 774 1157 !!---------------------------------------------------------------------- 775 1158 !! *** ROUTINE Agrif_get_proc_info *** 776 1159 !!---------------------------------------------------------------------- 777 USE par_oce778 USE dom_oce779 !!780 IMPLICIT NONE781 !782 INTEGER, INTENT(out) :: imin, imax783 INTEGER, INTENT(out) :: jmin, jmax784 !!----------------------------------------------------------------------785 !786 imin = nimppt(Agrif_Procrank+1) ! ?????787 jmin = njmppt(Agrif_Procrank+1) ! ?????788 imax = imin + jpi - 1789 jmax = jmin + jpj - 1790 !791 END SUBROUTINE Agrif_get_proc_info792 793 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost)1160 USE par_oce 1161 USE dom_oce 1162 !! 1163 IMPLICIT NONE 1164 ! 1165 INTEGER, INTENT(out) :: imin, imax 1166 INTEGER, INTENT(out) :: jmin, jmax 1167 !!---------------------------------------------------------------------- 1168 ! 1169 imin = nimppt(Agrif_Procrank+1) ! ????? 1170 jmin = njmppt(Agrif_Procrank+1) ! ????? 1171 imax = imin + jpi - 1 1172 jmax = jmin + jpj - 1 1173 ! 1174 END SUBROUTINE Agrif_get_proc_info 1175 1176 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 794 1177 !!---------------------------------------------------------------------- 795 1178 !! *** ROUTINE Agrif_estimate_parallel_cost *** 796 1179 !!---------------------------------------------------------------------- 797 USE par_oce798 !!799 IMPLICIT NONE800 !801 INTEGER, INTENT(in) :: imin, imax802 INTEGER, INTENT(in) :: jmin, jmax803 INTEGER, INTENT(in) :: nbprocs804 REAL(wp), INTENT(out) :: grid_cost805 !!----------------------------------------------------------------------806 !807 grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp)808 !809 END SUBROUTINE Agrif_estimate_parallel_cost810 1180 USE par_oce 1181 !! 1182 IMPLICIT NONE 1183 ! 1184 INTEGER, INTENT(in) :: imin, imax 1185 INTEGER, INTENT(in) :: jmin, jmax 1186 INTEGER, INTENT(in) :: nbprocs 1187 REAL(wp), INTENT(out) :: grid_cost 1188 !!---------------------------------------------------------------------- 1189 ! 1190 grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 1191 ! 1192 END SUBROUTINE Agrif_estimate_parallel_cost 1193 # endif 811 1194 #endif -
utils/tools/DOMAINcfg/src/bilinear_interp.f90
r12414 r13204 1 ! 1 2 MODULE bilinear_interp 2 3 END MODULE 3 ! 4 USE agrif_modutil 5 ! 6 !************************************************************************ 7 ! * 8 ! MODULE BILINEAR INTERP * 9 ! * 10 ! bilinear interpolation routines from SCRIP package * 11 ! * 12 !http://climate.lanl.gov/Software/SCRIP/ * 13 ! * 14 !Bilinear remapping * 15 ! * 16 !************************************************************************ 17 ! 18 !----------------------------------------------------------------------- 19 IMPLICIT NONE 20 21 !----------------------------------------------------------------------- 22 ! variables that describe each grid 23 !----------------------------------------------------------------------- 24 ! 25 INTEGER :: grid1_size,grid2_size,grid1_rank, grid2_rank 26 ! 27 INTEGER, DIMENSION(:), ALLOCATABLE :: grid1_dims, grid2_dims 28 ! 29 30 !----------------------------------------------------------------------- 31 ! grid coordinates and masks 32 !----------------------------------------------------------------------- 33 ! 34 LOGICAL, DIMENSION(:), ALLOCATABLE :: grid1_mask,grid2_mask 35 ! each grid center in radians 36 REAL*8,DIMENSION(:), ALLOCATABLE :: & 37 grid1_center_lat, & 38 grid1_center_lon, & 39 grid2_center_lat, & 40 grid2_center_lon, & 41 grid1_frac, & ! fractional area of grid cells 42 grid2_frac ! participating in remapping 43 ! 44 ! lat/lon bounding box for use in restricting grid searches 45 ! 46 REAL*8,DIMENSION(:,:), ALLOCATABLE :: grid1_bound_box,grid2_bound_box 47 ! 48 !----------------------------------------------------------------------- 49 ! bins for restricting searches 50 !----------------------------------------------------------------------- 51 ! 52 ! num of bins for restricted srch 53 INTEGER, PARAMETER :: num_srch_bins = 90 54 ! 55 ! min,max adds for grid cells in this lat bin 56 ! 57 INTEGER,DIMENSION(:,:), ALLOCATABLE :: bin_addr1,bin_addr2 58 ! 59 ! min,max longitude for each search bin 60 ! 61 REAL*8, DIMENSION(:,:), ALLOCATABLE :: bin_lats,bin_lons 62 63 REAL*8, PARAMETER :: zero = 0.0, & 64 one = 1.0, & 65 two = 2.0, & 66 three = 3.0, & 67 four = 4.0, & 68 five = 5.0, & 69 half = 0.5, & 70 quart = 0.25, & 71 bignum = 1.e+20, & 72 tiny = 1.e-14, & 73 pi = 3.14159265359, & 74 pi2 = two*pi, & 75 pih = half*pi 76 77 REAL*8, PARAMETER :: deg2rad = pi/180. 78 ! 79 ! max iteration count for i,j iteration 80 ! 81 INTEGER , PARAMETER :: max_iter = 100 82 ! 83 ! convergence criterion 84 ! 85 REAL*8, PARAMETER :: converge = 1.e-10 86 87 88 ! 89 INTEGER, PARAMETER :: norm_opt_none = 1 & 90 ,norm_opt_dstarea = 2 & 91 ,norm_opt_frcarea = 3 92 ! 93 INTEGER, PARAMETER :: map_type_conserv = 1 & 94 ,map_type_bilinear = 2 & 95 ,map_type_bicubic = 3 & 96 ,map_type_distwgt = 4 97 ! 98 INTEGER :: max_links_map1 & ! current size of link arrays 99 ,num_links_map1 & ! actual number of links for remapping 100 ,max_links_map2 & ! current size of link arrays 101 ,num_links_map2 & ! actual number of links for remapping 102 ,num_maps & ! num of remappings for this grid pair 103 ,num_wts & ! num of weights used in remapping 104 ,map_type & ! identifier for remapping method 105 ,norm_opt & ! option for normalization (conserv only) 106 ,resize_increment ! default amount to increase array size 107 108 INTEGER , DIMENSION(:), ALLOCATABLE :: & 109 grid1_add_map1, & ! grid1 address for each link in mapping 1 110 grid2_add_map1, & ! grid2 address for each link in mapping 1 111 grid1_add_map2, & ! grid1 address for each link in mapping 2 112 grid2_add_map2 ! grid2 address for each link in mapping 2 113 114 REAL*8, DIMENSION(:,:), ALLOCATABLE :: & 115 wts_map1, & ! map weights for each link (num_wts,max_links) 116 wts_map2 ! map weights for each link (num_wts,max_links) 117 ! 118 CONTAINS 119 ! 120 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 121 !************************************************************************ 122 ! SUBROUTINE GRID_INIT 123 !************************************************************************ 124 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 125 ! 126 SUBROUTINE get_remap_matrix(grid1_lat,grid2_lat,grid1_lon,grid2_lon,mask, & 127 remap_matrix,source_add,destination_add) 128 ! 129 !----------------------------------------------------------------------- 130 !this routine makes any necessary changes (e.g. for 0,2pi longitude range) 131 !----------------------------------------------------------------------- 132 ! 133 REAL*8,DIMENSION(:,:) :: grid1_lat,grid2_lat,grid1_lon,grid2_lon 134 LOGICAL,DIMENSION(:,:) :: mask 135 ! 136 INTEGER,DIMENSION(:),ALLOCATABLE :: source_add,destination_add 137 REAL*8,DIMENSION(:,:), ALLOCATABLE :: remap_matrix 138 ! 139 !----------------------------------------------------------------------- 140 ! local variables 141 !----------------------------------------------------------------------- 142 ! 143 INTEGER :: n,nele,i,j,ip1,jp1,n_add,e_add,ne_add,nx,ny 144 INTEGER :: xpos,ypos 145 ! 146 ! integer mask 147 ! 148 INTEGER, DIMENSION(:), ALLOCATABLE :: imask 149 ! 150 ! lat/lon intervals for search bins 151 ! 152 REAL*8 :: dlat,dlon 153 ! 154 ! temps for computing bounding boxes 155 ! 156 REAL*8, DIMENSION(4) :: tmp_lats, tmp_lons 157 ! 158 ! write(*,*)'proceed to Bilinear interpolation ...' 159 ! 160 ! IF(ALLOCATED(wts_map1)) DEALLOCATE(wts_map1) 161 ! IF(ALLOCATED(grid1_add_map1)) DEALLOCATE(grid1_add_map1) 162 ! IF(ALLOCATED(grid2_add_map1)) DEALLOCATE(grid2_add_map1) 163 164 165 ! 166 ALLOCATE(grid1_dims(2),grid2_dims(2)) 167 ! 168 grid1_dims(1) = SIZE(grid1_lat,2) 169 grid1_dims(2) = SIZE(grid1_lat,1) 170 grid2_dims(1) = SIZE(grid2_lat,2) 171 grid2_dims(2) = SIZE(grid2_lat,1) 172 grid1_size = SIZE(grid1_lat,2) * SIZE(grid1_lat,1) 173 grid2_size = SIZE(grid2_lat,2) * SIZE(grid2_lat,1) 174 ! 175 !----------------------------------------------------------------------- 176 ! allocate grid coordinates/masks and read data 177 !----------------------------------------------------------------------- 178 ! 179 ALLOCATE( grid2_mask(grid2_size), & 180 grid1_bound_box (4,grid1_size), & 181 grid2_bound_box (4,grid2_size), & 182 grid1_frac (grid1_size), & 183 grid2_frac (grid2_size)) 184 ALLOCATE(imask(grid1_size)) 185 ! 186 ! 187 grid1_frac = zero 188 grid2_frac = zero 189 190 ! 191 ! 2D array -> 1D array 192 ! 193 ALLOCATE(grid1_center_lat(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) 194 CALL tab2Dto1D(grid1_lat,grid1_center_lat) 195 196 ALLOCATE(grid1_center_lon(SIZE(grid1_lon,1)*SIZE(grid1_lon,2))) 197 CALL tab2Dto1D(grid1_lon,grid1_center_lon) 198 199 ALLOCATE(grid2_center_lat(SIZE(grid2_lat,1)*SIZE(grid2_lat,2))) 200 CALL tab2Dto1D(grid2_lat,grid2_center_lat) 201 202 ALLOCATE(grid2_center_lon(SIZE(grid2_lon,1)*SIZE(grid2_lon,2))) 203 CALL tab2Dto1D(grid2_lon,grid2_center_lon) 204 205 ALLOCATE(grid1_mask(SIZE(grid1_lat,1)*SIZE(grid1_lat,2))) 206 CALL logtab2Dto1D(mask,grid1_mask) 207 ! 208 ! Write(*,*) ,'grid1_mask = ',grid1_mask 209 ! 210 ! degrees to radian 211 ! 212 grid1_center_lat = grid1_center_lat*deg2rad 213 grid1_center_lon = grid1_center_lon*deg2rad 214 grid2_center_lat = grid2_center_lat*deg2rad 215 grid2_center_lon = grid2_center_lon*deg2rad 216 217 !----------------------------------------------------------------------- 218 ! convert longitudes to 0,2pi interval 219 !----------------------------------------------------------------------- 220 221 WHERE (grid1_center_lon .GT. pi2) grid1_center_lon = & 222 grid1_center_lon - pi2 223 WHERE (grid1_center_lon .LT. zero) grid1_center_lon = & 224 grid1_center_lon + pi2 225 WHERE (grid2_center_lon .GT. pi2) grid2_center_lon = & 226 grid2_center_lon - pi2 227 WHERE (grid2_center_lon .LT. zero) grid2_center_lon = & 228 grid2_center_lon + pi2 229 230 !----------------------------------------------------------------------- 231 ! 232 ! make sure input latitude range is within the machine values 233 ! for +/- pi/2 234 ! 235 !----------------------------------------------------------------------- 236 237 WHERE (grid1_center_lat > pih) grid1_center_lat = pih 238 WHERE (grid1_center_lat < -pih) grid1_center_lat = -pih 239 WHERE (grid2_center_lat > pih) grid2_center_lat = pih 240 WHERE (grid2_center_lat < -pih) grid2_center_lat = -pih 241 242 !----------------------------------------------------------------------- 243 ! 244 ! compute bounding boxes for restricting future grid searches 245 ! 246 !----------------------------------------------------------------------- 247 ! 248 nx = grid1_dims(1) 249 ny = grid1_dims(2) 250 251 DO n=1,grid1_size 252 253 !*** find N,S and NE points to this grid point 254 255 j = (n - 1)/nx +1 256 i = n - (j-1)*nx 257 258 IF (i < nx) THEN 259 ip1 = i + 1 260 ELSE 261 !*** assume cyclic 262 ip1 = 1 263 !*** but if it is not, correct 264 e_add = (j - 1)*nx + ip1 265 IF (ABS(grid1_center_lat(e_add) - & 266 grid1_center_lat(n )) > pih) THEN 267 ip1 = i 268 ENDIF 269 ip1=nx 270 ENDIF 271 272 IF (j < ny) THEN 273 jp1 = j+1 274 ELSE 275 !*** assume cyclic 276 jp1 = 1 277 !*** but if it is not, correct 278 n_add = (jp1 - 1)*nx + i 279 IF (ABS(grid1_center_lat(n_add) - & 280 grid1_center_lat(n )) > pih) THEN 281 jp1 = j 282 ENDIF 283 jp1=ny 284 ENDIF 285 286 n_add = (jp1 - 1)*nx + i 287 e_add = (j - 1)*nx + ip1 288 ne_add = (jp1 - 1)*nx + ip1 289 290 !*** find N,S and NE lat/lon coords and check bounding box 291 292 tmp_lats(1) = grid1_center_lat(n) 293 tmp_lats(2) = grid1_center_lat(e_add) 294 tmp_lats(3) = grid1_center_lat(ne_add) 295 tmp_lats(4) = grid1_center_lat(n_add) 296 297 tmp_lons(1) = grid1_center_lon(n) 298 tmp_lons(2) = grid1_center_lon(e_add) 299 tmp_lons(3) = grid1_center_lon(ne_add) 300 tmp_lons(4) = grid1_center_lon(n_add) 301 302 grid1_bound_box(1,n) = MINVAL(tmp_lats) 303 grid1_bound_box(2,n) = MAXVAL(tmp_lats) 304 305 grid1_bound_box(3,n) = MINVAL(tmp_lons) 306 grid1_bound_box(4,n) = MAXVAL(tmp_lons) 307 END DO 308 309 nx = grid2_dims(1) 310 ny = grid2_dims(2) 311 312 DO n=1,grid2_size 313 314 !*** find N,S and NE points to this grid point 315 316 j = (n - 1)/nx +1 317 i = n - (j-1)*nx 318 319 IF (i < nx) THEN 320 ip1 = i + 1 321 ELSE 322 !*** assume cyclic 323 ip1 = 1 324 !*** but if it is not, correct 325 e_add = (j - 1)*nx + ip1 326 IF (ABS(grid2_center_lat(e_add) - & 327 grid2_center_lat(n )) > pih) THEN 328 ip1 = i 329 ENDIF 330 ENDIF 331 332 IF (j < ny) THEN 333 jp1 = j+1 334 ELSE 335 !*** assume cyclic 336 jp1 = 1 337 !*** but if it is not, correct 338 n_add = (jp1 - 1)*nx + i 339 IF (ABS(grid2_center_lat(n_add) - & 340 grid2_center_lat(n )) > pih) THEN 341 jp1 = j 342 ENDIF 343 ENDIF 344 345 n_add = (jp1 - 1)*nx + i 346 e_add = (j - 1)*nx + ip1 347 ne_add = (jp1 - 1)*nx + ip1 348 349 !*** find N,S and NE lat/lon coords and check bounding box 350 351 tmp_lats(1) = grid2_center_lat(n) 352 tmp_lats(2) = grid2_center_lat(e_add) 353 tmp_lats(3) = grid2_center_lat(ne_add) 354 tmp_lats(4) = grid2_center_lat(n_add) 355 356 tmp_lons(1) = grid2_center_lon(n) 357 tmp_lons(2) = grid2_center_lon(e_add) 358 tmp_lons(3) = grid2_center_lon(ne_add) 359 tmp_lons(4) = grid2_center_lon(n_add) 360 361 grid2_bound_box(1,n) = MINVAL(tmp_lats) 362 grid2_bound_box(2,n) = MAXVAL(tmp_lats) 363 grid2_bound_box(3,n) = MINVAL(tmp_lons) 364 grid2_bound_box(4,n) = MAXVAL(tmp_lons) 365 END DO 366 ! 367 ! 368 ! 369 WHERE (ABS(grid1_bound_box(4,:) - grid1_bound_box(3,:)) > pi) 370 grid1_bound_box(3,:) = zero 371 grid1_bound_box(4,:) = pi2 372 END WHERE 373 374 WHERE (ABS(grid2_bound_box(4,:) - grid2_bound_box(3,:)) > pi) 375 grid2_bound_box(3,:) = zero 376 grid2_bound_box(4,:) = pi2 377 END WHERE 378 379 !*** 380 !*** try to check for cells that overlap poles 381 !*** 382 383 WHERE (grid1_center_lat > grid1_bound_box(2,:)) & 384 grid1_bound_box(2,:) = pih 385 386 WHERE (grid1_center_lat < grid1_bound_box(1,:)) & 387 grid1_bound_box(1,:) = -pih 388 389 WHERE (grid2_center_lat > grid2_bound_box(2,:)) & 390 grid2_bound_box(2,:) = pih 391 392 WHERE (grid2_center_lat < grid2_bound_box(1,:)) & 393 grid2_bound_box(1,:) = -pih 394 395 !----------------------------------------------------------------------- 396 ! set up and assign address ranges to search bins in order to 397 ! further restrict later searches 398 !----------------------------------------------------------------------- 399 400 ALLOCATE(bin_addr1(2,num_srch_bins)) 401 ALLOCATE(bin_addr2(2,num_srch_bins)) 402 ALLOCATE(bin_lats (2,num_srch_bins)) 403 ALLOCATE(bin_lons (2,num_srch_bins)) 404 405 dlat = pi/num_srch_bins 406 407 DO n=1,num_srch_bins 408 bin_lats(1,n) = (n-1)*dlat - pih 409 bin_lats(2,n) = n*dlat - pih 410 bin_lons(1,n) = zero 411 bin_lons(2,n) = pi2 412 bin_addr1(1,n) = grid1_size + 1 413 bin_addr1(2,n) = 0 414 bin_addr2(1,n) = grid2_size + 1 415 bin_addr2(2,n) = 0 416 END DO 417 418 DO nele=1,grid1_size 419 DO n=1,num_srch_bins 420 IF (grid1_bound_box(1,nele) <= bin_lats(2,n) .AND. & 421 grid1_bound_box(2,nele) >= bin_lats(1,n)) THEN 422 bin_addr1(1,n) = MIN(nele,bin_addr1(1,n)) 423 bin_addr1(2,n) = MAX(nele,bin_addr1(2,n)) 424 ENDIF 425 END DO 426 END DO 427 428 DO nele=1,grid2_size 429 DO n=1,num_srch_bins 430 IF (grid2_bound_box(1,nele) <= bin_lats(2,n) .AND. & 431 grid2_bound_box(2,nele) >= bin_lats(1,n)) THEN 432 bin_addr2(1,n) = MIN(nele,bin_addr2(1,n)) 433 bin_addr2(2,n) = MAX(nele,bin_addr2(2,n)) 434 ENDIF 435 END DO 436 END DO 437 ! 438 CALL init_remap_vars 439 CALL remap_bilin 440 441 ALLOCATE(remap_matrix(SIZE(wts_map1,1),SIZE(wts_map1,2)), & 442 source_add(SIZE(grid1_add_map1)), & 443 destination_add(SIZE(grid2_add_map1))) 444 445 DO j = 1,SIZE(wts_map1,2) 446 DO i = 1,SIZE(wts_map1,1) 447 448 remap_matrix(i,j) = wts_map1(i,j) 449 450 END DO 451 END DO 452 453 454 source_add(:) = grid1_add_map1(:) 455 destination_add(:) = grid2_add_map1(:) 456 ! 457 WHERE(destination_add == 0) 458 destination_add = 1 459 END WHERE 460 461 WHERE(source_add == 0) 462 source_add = 1 463 END WHERE 464 ! 465 !DEALLOCATE(grid1_bound_box,grid2_bound_box,grid1_center_lat,grid1_center_lon) 466 !DEALLOCATE(grid2_center_lat,grid2_center_lon,grid2_add_map1,grid1_add_map1,wts_map1) 467 !DEALLOCATE(grid1_frac,grid2_frac,grid1_dims,grid2_dims,grid2_mask,imask) 468 !DEALLOCATE(bin_addr1,bin_addr2,bin_lats,bin_lons) 469 !DEALLOCATE(grid1_mask) 470 ! 471 !----------------------------------------------------------------------- 472 473 END SUBROUTINE get_remap_matrix 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 !*********************************************************************** 499 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 500 !************************************************************************ 501 ! SUBROUTINE REMAP_BILINEAR 502 !************************************************************************ 503 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 504 505 SUBROUTINE remap_bilin 506 507 !----------------------------------------------------------------------- 508 ! this routine computes the weights for a bilinear interpolation. 509 !----------------------------------------------------------------------- 510 511 !----------------------------------------------------------------------- 512 ! local variables 513 !----------------------------------------------------------------------- 514 515 INTEGER :: n,icount,dst_add,iter,nmap,nbmasked 516 ! 517 ! address for the four source points 518 ! 519 INTEGER, DIMENSION(4) :: src_add,involved_pts 520 INTEGER, DIMENSION(1) :: minlon 521 INTEGER, DIMENSION(1) :: minlat 522 REAL*8, DIMENSION(4) :: distx,disty 523 REAL*8 :: normalize 524 ! 525 ! latitudes longitudes of four bilinear corners 526 ! 527 REAL*8, DIMENSION(4) :: src_lats,src_lons 528 ! 529 ! bilinear weights for four corners 530 ! 531 REAL*8, DIMENSION(4) :: wgts 532 ! 533 REAL*8 :: & 534 plat, plon, & ! lat/lon coords of destination point 535 iguess, jguess, & ! current guess for bilinear coordinate 536 thguess, phguess, & ! current guess for lat/lon coordinate 537 deli, delj, & ! corrections to i,j 538 dth1, dth2, dth3, & ! some latitude differences 539 dph1, dph2, dph3, & ! some longitude differences 540 dthp, dphp, & ! difference between point and sw corner 541 mat1, mat2, mat3, mat4, & ! matrix elements 542 determinant, & ! matrix determinant 543 sum_wgts ! sum of weights for normalization 544 545 INTEGER lastsrc_add 546 REAL*8,DIMENSION(:),ALLOCATABLE :: cos_grid1_center_lat 547 REAL*8,DIMENSION(:),ALLOCATABLE :: cos_grid1_center_lon 548 REAL*8,DIMENSION(:),ALLOCATABLE :: sin_grid1_center_lat 549 REAL*8,DIMENSION(:),ALLOCATABLE :: sin_grid1_center_lon 550 INTEGER :: i 551 ! 552 grid2_mask = .TRUE. 553 ! 554 ! 555 nmap = 1 556 ! 557 !*** 558 !*** loop over destination grid 559 !*** 560 ! print*,'grid2_size =',grid2_size 561 ! 562 lastsrc_add=1 563 ! 564 Allocate(cos_grid1_center_lat(size(grid1_center_lat))) 565 Allocate(sin_grid1_center_lat(size(grid1_center_lat))) 566 Allocate(cos_grid1_center_lon(size(grid1_center_lon))) 567 Allocate(sin_grid1_center_lon(size(grid1_center_lon))) 568 569 do i=1,size(grid1_center_lat) 570 cos_grid1_center_lat(i)=cos(grid1_center_lat(i)) 571 sin_grid1_center_lat(i)=sin(grid1_center_lat(i)) 572 ENDDO 573 574 do i=1,size(grid1_center_lon) 575 cos_grid1_center_lon(i)=cos(grid1_center_lon(i)) 576 sin_grid1_center_lon(i)=sin(grid1_center_lon(i)) 577 ENDDO 578 579 grid_loop1: DO dst_add = 1, grid2_size 580 581 IF (.NOT. grid2_mask(dst_add)) CYCLE grid_loop1 582 ! 583 plat = grid2_center_lat(dst_add) 584 plon = grid2_center_lon(dst_add) 585 !*** 586 !*** find nearest square of grid points on source grid 587 !*** 588 CALL grid_search_bilin(src_add, src_lats, src_lons, & 589 plat, plon, grid1_dims, & 590 grid1_center_lat, cos_grid1_center_lat, sin_grid1_center_lat, & 591 grid1_center_lon, cos_grid1_center_lon, sin_grid1_center_lon, & 592 grid1_bound_box, bin_addr1, bin_addr2,lastsrc_add) 593 !*** 594 !*** check to see if points are land points 595 !*** 596 ! 597 IF (src_add(1) > 0) THEN 598 ! 599 DO n=1,4 600 ! if(.not. grid1_mask(src_add(n))) nbmasked = nbmasked + 1 601 IF(.NOT. grid1_mask(src_add(n))) src_add(1) = 0 602 END DO 603 ! 604 ENDIF 605 ! 606 ! 607 608 !*** 609 !*** if point found, find local i,j coordinates for weights 610 !*** 611 IF (src_add(1) > 0) THEN 612 grid2_frac(dst_add) = one 613 !*** 614 !*** iterate to find i,j for bilinear approximation 615 !*** 616 dth1 = src_lats(2) - src_lats(1) 617 dth2 = src_lats(4) - src_lats(1) 618 dth3 = src_lats(3) - src_lats(2) - dth2 619 620 dph1 = src_lons(2) - src_lons(1) 621 dph2 = src_lons(4) - src_lons(1) 622 dph3 = src_lons(3) - src_lons(2) 623 624 IF (dph1 > three*pih) dph1 = dph1 - pi2 625 IF (dph2 > three*pih) dph2 = dph2 - pi2 626 IF (dph3 > three*pih) dph3 = dph3 - pi2 627 IF (dph1 < -three*pih) dph1 = dph1 + pi2 628 IF (dph2 < -three*pih) dph2 = dph2 + pi2 629 IF (dph3 < -three*pih) dph3 = dph3 + pi2 630 631 dph3 = dph3 - dph2 632 633 iguess = half 634 jguess = half 635 636 iter_loop1: DO iter=1,max_iter 637 638 dthp = plat - src_lats(1) - dth1*iguess - & 639 dth2*jguess - dth3*iguess*jguess 640 dphp = plon - src_lons(1) 641 642 IF (dphp > three*pih) dphp = dphp - pi2 643 IF (dphp < -three*pih) dphp = dphp + pi2 644 645 dphp = dphp - dph1*iguess - dph2*jguess - & 646 dph3*iguess*jguess 647 648 mat1 = dth1 + dth3*jguess 649 mat2 = dth2 + dth3*iguess 650 mat3 = dph1 + dph3*jguess 651 mat4 = dph2 + dph3*iguess 652 653 determinant = mat1*mat4 - mat2*mat3 654 655 deli = (dthp*mat4 - mat2*dphp)/determinant 656 delj = (mat1*dphp - dthp*mat3)/determinant 657 658 IF (ABS(deli) < converge .AND. & 659 ABS(delj) < converge) EXIT iter_loop1 660 661 iguess = iguess + deli 662 jguess = jguess + delj 663 664 END DO iter_loop1 665 666 IF (iter <= max_iter) THEN 667 668 !*** 669 !*** successfully found i,j - compute weights 670 !*** 671 672 wgts(1) = (one-iguess)*(one-jguess) 673 wgts(2) = iguess*(one-jguess) 674 wgts(3) = iguess*jguess 675 wgts(4) = (one-iguess)*jguess 676 ! 677 ! 678 CALL store_link_bilin(dst_add, src_add, wgts, nmap) 679 680 ELSE 681 PRINT *,'Point coords: ',plat,plon 682 PRINT *,'Dest grid lats: ',src_lats 683 PRINT *,'Dest grid lons: ',src_lons 684 PRINT *,'Dest grid addresses: ',src_add 685 PRINT *,'Current i,j : ',iguess, jguess 686 STOP 'Iteration for i,j exceed max iteration count' 687 ENDIF 688 ! 689 !*** 690 !*** search for bilinear failed - use a distance-weighted 691 !*** average instead (this is typically near the pole) 692 !*** 693 ELSE IF (src_add(1) < 0) THEN 694 695 src_add = ABS(src_add) 696 icount = 0 697 DO n=1,4 698 ! 699 IF (grid1_mask(src_add(n))) THEN 700 icount = icount + 1 701 ELSE 702 src_lats(n) = zero 703 ENDIF 704 ! 705 END DO 706 707 IF (icount > 0) THEN 708 ! 709 !*** renormalize weights 710 ! 711 sum_wgts = SUM(src_lats) 712 wgts(1) = src_lats(1)/sum_wgts 713 wgts(2) = src_lats(2)/sum_wgts 714 wgts(3) = src_lats(3)/sum_wgts 715 wgts(4) = src_lats(4)/sum_wgts 716 ! 717 grid2_frac(dst_add) = one 718 CALL store_link_bilin(dst_add, src_add, wgts, nmap) 719 ENDIF 720 721 ! 722 ENDIF 723 END DO grid_loop1 724 ! 725 ! Call sort_add(grid2_add_map1, grid1_add_map1, wts_map1) 726 ! 727 ! 728 !----------------------------------------------------------------------- 729 730 deallocate(cos_grid1_center_lat) 731 deallocate(cos_grid1_center_lon) 732 deallocate(sin_grid1_center_lat) 733 deallocate(sin_grid1_center_lon) 734 END SUBROUTINE remap_bilin 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 !*********************************************************************** 754 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 755 !************************************************************************ 756 ! SUBROUTINE GRID_SEARCH_BILIN 757 !************************************************************************ 758 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 759 ! 760 SUBROUTINE grid_search_bilin(src_add, src_lats, src_lons, & 761 plat, plon, src_grid_dims, & 762 src_center_lat, cos_src_center_lat, sin_src_center_lat, & 763 src_center_lon, cos_src_center_lon, sin_src_center_lon,& 764 src_grid_bound_box, & 765 src_bin_add, dst_bin_add,lastsrc_add) 766 767 !----------------------------------------------------------------------- 768 ! 769 ! this routine finds the location of the search point plat, plon 770 ! in the source grid and returns the corners needed for a bilinear 771 ! interpolation. 772 ! 773 !----------------------------------------------------------------------- 774 775 !----------------------------------------------------------------------- 776 ! output variables 777 !----------------------------------------------------------------------- 778 ! 779 ! address of each corner point enclosing P 780 ! 781 INTEGER,DIMENSION(4) :: src_add 782 REAL*8,DIMENSION(4) :: src_lats,src_lons 783 ! 784 !----------------------------------------------------------------------- 785 ! input variables 786 !----------------------------------------------------------------------- 787 ! 788 ! latitude, longitude of the search point 789 ! 790 REAL*8, INTENT(in) :: plat,plon 791 ! 792 ! size of each src grid dimension 793 ! 794 INTEGER, DIMENSION(2), INTENT(in) :: src_grid_dims 795 ! 796 ! latitude, longitude of each src grid center 797 ! 798 REAL*8, DIMENSION(:), INTENT(in) :: src_center_lat,src_center_lon 799 REAL*8, DIMENSION(:), INTENT(in) :: cos_src_center_lat 800 REAL*8, DIMENSION(:), INTENT(in) :: sin_src_center_lat 801 REAL*8, DIMENSION(:), INTENT(in) :: cos_src_center_lon 802 REAL*8, DIMENSION(:), INTENT(in) :: sin_src_center_lon 803 ! 804 ! bound box for source grid 805 ! 806 REAL*8, DIMENSION(:,:), INTENT(in) :: src_grid_bound_box 807 ! 808 ! latitude bins for restricting searches 809 ! 810 INTEGER, DIMENSION(:,:), INTENT(in) ::src_bin_add,dst_bin_add 811 812 INTEGER,OPTIONAL :: lastsrc_add 813 INTEGER :: loopsrc,l1,l2 814 ! 815 !----------------------------------------------------------------------- 816 ! local variables 817 !----------------------------------------------------------------------- 818 ! 819 INTEGER :: n,next_n,srch_add,nx, ny,min_add, max_add, & 820 i, j, jp1, ip1, n_add, e_add, ne_add 821 822 823 REAL*8 :: vec1_lat, vec1_lon,vec2_lat, vec2_lon, cross_product, & 824 cross_product_last,coslat_dst, sinlat_dst, coslon_dst, & 825 sinlon_dst,dist_min, distance 826 827 !----------------------------------------------------------------------- 828 ! restrict search first using bins 829 !----------------------------------------------------------------------- 830 831 src_add = 0 832 833 min_add = SIZE(src_center_lat) 834 max_add = 1 835 DO n=1,num_srch_bins 836 IF (plat >= bin_lats(1,n) .AND. plat <= bin_lats(2,n) .AND. & 837 plon >= bin_lons(1,n) .AND. plon <= bin_lons(2,n)) THEN 838 min_add = MIN(min_add, src_bin_add(1,n)) 839 max_add = MAX(max_add, src_bin_add(2,n)) 840 ENDIF 841 END DO 842 843 !----------------------------------------------------------------------- 844 ! now perform a more detailed search 845 !----------------------------------------------------------------------- 846 847 nx = src_grid_dims(1) 848 ny = src_grid_dims(2) 849 850 loopsrc=0 851 DO WHILE (loopsrc <= max_add) 852 853 854 l1=MAX(min_add,lastsrc_add-loopsrc) 855 l2=MIN(max_add,lastsrc_add+loopsrc) 856 857 loopsrc = loopsrc+1 858 859 srch_loop: DO srch_add = l1,l2,MAX(l2-l1,1) 860 861 !*** first check bounding box 862 863 IF (plat <= src_grid_bound_box(2,srch_add) .AND. & 864 plat >= src_grid_bound_box(1,srch_add) .AND. & 865 plon <= src_grid_bound_box(4,srch_add) .AND. & 866 plon >= src_grid_bound_box(3,srch_add)) THEN 867 !*** 868 !*** we are within bounding box so get really serious 869 !*** 870 !*** determine neighbor addresses 871 ! 872 j = (srch_add - 1)/nx +1 873 i = srch_add - (j-1)*nx 874 ! 875 IF (i < nx) THEN 876 ip1 = i + 1 877 ELSE 878 ip1 = 1 879 ENDIF 880 ! 881 IF (j < ny) THEN 882 jp1 = j+1 883 ELSE 884 jp1 = 1 885 ENDIF 886 ! 887 n_add = (jp1 - 1)*nx + i 888 e_add = (j - 1)*nx + ip1 889 ne_add = (jp1 - 1)*nx + ip1 890 ! 891 src_lats(1) = src_center_lat(srch_add) 892 src_lats(2) = src_center_lat(e_add) 893 src_lats(3) = src_center_lat(ne_add) 894 src_lats(4) = src_center_lat(n_add) 895 ! 896 src_lons(1) = src_center_lon(srch_add) 897 src_lons(2) = src_center_lon(e_add) 898 src_lons(3) = src_center_lon(ne_add) 899 src_lons(4) = src_center_lon(n_add) 900 ! 901 !*** 902 !*** for consistency, we must make sure all lons are in 903 !*** same 2pi interval 904 !*** 905 ! 906 vec1_lon = src_lons(1) - plon 907 IF (vec1_lon > pi) THEN 908 src_lons(1) = src_lons(1) - pi2 909 ELSE IF (vec1_lon < -pi) THEN 910 src_lons(1) = src_lons(1) + pi2 911 ENDIF 912 DO n=2,4 913 vec1_lon = src_lons(n) - src_lons(1) 914 IF (vec1_lon > pi) THEN 915 src_lons(n) = src_lons(n) - pi2 916 ELSE IF (vec1_lon < -pi) THEN 917 src_lons(n) = src_lons(n) + pi2 918 ENDIF 919 END DO 920 ! 921 corner_loop: DO n=1,4 922 next_n = MOD(n,4) + 1 923 !*** 924 !*** here we take the cross product of the vector making 925 !*** up each box side with the vector formed by the vertex 926 !*** and search point. if all the cross products are 927 !*** positive, the point is contained in the box. 928 !*** 929 vec1_lat = src_lats(next_n) - src_lats(n) 930 vec1_lon = src_lons(next_n) - src_lons(n) 931 vec2_lat = plat - src_lats(n) 932 vec2_lon = plon - src_lons(n) 933 !*** 934 !*** check for 0,2pi crossings 935 !*** 936 IF (vec1_lon > three*pih) THEN 937 vec1_lon = vec1_lon - pi2 938 ELSE IF (vec1_lon < -three*pih) THEN 939 vec1_lon = vec1_lon + pi2 940 ENDIF 941 IF (vec2_lon > three*pih) THEN 942 vec2_lon = vec2_lon - pi2 943 ELSE IF (vec2_lon < -three*pih) THEN 944 vec2_lon = vec2_lon + pi2 945 ENDIF 946 ! 947 cross_product = vec1_lon*vec2_lat - vec2_lon*vec1_lat 948 ! 949 !*** 950 !*** if cross product is less than zero, this cell 951 !*** doesn't work 952 !*** 953 IF (n == 1) cross_product_last = cross_product 954 IF (cross_product*cross_product_last < zero) & 955 EXIT corner_loop 956 cross_product_last = cross_product 957 ! 958 END DO corner_loop 959 !*** 960 !*** if cross products all same sign, we found the location 961 !*** 962 IF (n > 4) THEN 963 src_add(1) = srch_add 964 src_add(2) = e_add 965 src_add(3) = ne_add 966 src_add(4) = n_add 967 ! 968 lastsrc_add = srch_add 969 RETURN 970 ENDIF 971 !*** 972 !*** otherwise move on to next cell 973 !*** 974 ENDIF !bounding box check 975 END DO srch_loop 976 977 978 ENDDO 979 980 981 !*** 982 !*** if no cell found, point is likely either in a box that 983 !*** straddles either pole or is outside the grid. fall back 984 !*** to a distance-weighted average of the four closest 985 !*** points. go ahead and compute weights here, but store 986 !*** in src_lats and return -add to prevent the parent 987 !*** routine from computing bilinear weights 988 !*** 989 !print *,'Could not find location for ',plat,plon 990 !print *,'Using nearest-neighbor average for this point' 991 ! 992 coslat_dst = COS(plat) 993 sinlat_dst = SIN(plat) 994 coslon_dst = COS(plon) 995 sinlon_dst = SIN(plon) 996 ! 997 dist_min = bignum 998 src_lats = bignum 999 DO srch_add = min_add,max_add 1000 ! distance = ACOS(coslat_dst*COS(src_center_lat(srch_add))* & 1001 ! (coslon_dst*COS(src_center_lon(srch_add)) + & 1002 ! sinlon_dst*SIN(src_center_lon(srch_add)))+ & 1003 ! sinlat_dst*SIN(src_center_lat(srch_add))) 1004 1005 distance = ACOS(coslat_dst*cos_src_center_lat(srch_add)* & 1006 (coslon_dst*cos_src_center_lon(srch_add) + & 1007 sinlon_dst*sin_src_center_lon(srch_add))+ & 1008 sinlat_dst*sin_src_center_lat(srch_add)) 1009 1010 IF (distance < dist_min) THEN 1011 sort_loop: DO n=1,4 1012 IF (distance < src_lats(n)) THEN 1013 DO i=4,n+1,-1 1014 src_add (i) = src_add (i-1) 1015 src_lats(i) = src_lats(i-1) 1016 END DO 1017 src_add (n) = -srch_add 1018 src_lats(n) = distance 1019 dist_min = src_lats(4) 1020 EXIT sort_loop 1021 ENDIF 1022 END DO sort_loop 1023 ENDIF 1024 END DO 1025 ! 1026 src_lons = one/(src_lats + tiny) 1027 distance = SUM(src_lons) 1028 src_lats = src_lons/distance 1029 1030 !----------------------------------------------------------------------- 1031 1032 END SUBROUTINE grid_search_bilin 1033 1034 1035 !*********************************************************************** 1036 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1037 !************************************************************************ 1038 ! SUBROUTINE STORE_LINK_BILIN 1039 !************************************************************************ 1040 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1041 1042 SUBROUTINE store_link_bilin(dst_add, src_add, weights, nmap) 1043 1044 !----------------------------------------------------------------------- 1045 ! this routine stores the address and weight for four links 1046 ! associated with one destination point in the appropriate address 1047 ! and weight arrays and resizes those arrays if necessary. 1048 !----------------------------------------------------------------------- 1049 1050 !----------------------------------------------------------------------- 1051 ! input variables 1052 !----------------------------------------------------------------------- 1053 ! 1054 INTEGER :: dst_add,nmap 1055 ! 1056 INTEGER, DIMENSION(4) :: src_add 1057 ! 1058 REAL*8, DIMENSION(4) :: weights 1059 1060 !----------------------------------------------------------------------- 1061 ! 1062 ! local variables 1063 ! 1064 !----------------------------------------------------------------------- 1065 1066 INTEGER :: n,num_links_old 1067 1068 !----------------------------------------------------------------------- 1069 ! increment number of links and check to see if remap arrays need 1070 ! to be increased to accomodate the new link. then store the 1071 ! link. 1072 !----------------------------------------------------------------------- 1073 1074 num_links_old = num_links_map1 1075 num_links_map1 = num_links_old + 4 1076 1077 IF (num_links_map1 > max_links_map1) & 1078 CALL resize_remap_vars(1,resize_increment) 1079 1080 DO n=1,4 1081 grid1_add_map1(num_links_old+n) = src_add(n) 1082 grid2_add_map1(num_links_old+n) = dst_add 1083 wts_map1 (1,num_links_old+n) = weights(n) 1084 END DO 1085 1086 !----------------------------------------------------------------------- 1087 1088 END SUBROUTINE store_link_bilin 1089 1090 1091 1092 1093 1094 1095 1096 1097 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1098 !************************************************************************ 1099 ! SUBROUTINE INIT_REMAP_VARS 1100 !************************************************************************ 1101 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1102 ! 1103 SUBROUTINE init_remap_vars 1104 1105 !----------------------------------------------------------------------- 1106 ! 1107 ! this routine initializes some variables and provides an initial 1108 ! allocation of arrays (fairly large so frequent resizing 1109 ! unnecessary). 1110 ! 1111 !----------------------------------------------------------------------- 1112 1113 !----------------------------------------------------------------------- 1114 ! determine the number of weights 1115 !----------------------------------------------------------------------- 1116 num_wts = 1 ! bilinear interpolation 1117 !----------------------------------------------------------------------- 1118 ! initialize num_links and set max_links to four times the largest 1119 ! of the destination grid sizes initially (can be changed later). 1120 ! set a default resize increment to increase the size of link 1121 ! arrays if the number of links exceeds the initial size 1122 !----------------------------------------------------------------------- 1123 1124 num_links_map1 = 0 1125 max_links_map1 = 4*grid2_size 1126 IF (num_maps > 1) THEN 1127 num_links_map2 = 0 1128 max_links_map1 = MAX(4*grid1_size,4*grid2_size) 1129 max_links_map2 = max_links_map1 1130 ENDIF 1131 1132 resize_increment = 0.1*MAX(grid1_size,grid2_size) 1133 1134 !----------------------------------------------------------------------- 1135 ! allocate address and weight arrays for mapping 1 1136 !----------------------------------------------------------------------- 1137 1138 ALLOCATE (grid1_add_map1(max_links_map1), & 1139 grid2_add_map1(max_links_map1), & 1140 wts_map1(num_wts, max_links_map1)) 1141 1142 grid1_add_map1 = 0. 1143 grid2_add_map1 = 0. 1144 wts_map1 = 0. 1145 1146 !----------------------------------------------------------------------- 1147 1148 END SUBROUTINE init_remap_vars 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 !*********************************************************************** 1164 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1165 !************************************************************************ 1166 ! SUBROUTINE RESIZE_REMAP_VAR 1167 !************************************************************************ 1168 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1169 1170 SUBROUTINE resize_remap_vars(nmap, increment) 1171 1172 !----------------------------------------------------------------------- 1173 ! this routine resizes remapping arrays by increasing(decreasing) 1174 ! the max_links by increment 1175 !----------------------------------------------------------------------- 1176 1177 !----------------------------------------------------------------------- 1178 ! input variables 1179 !----------------------------------------------------------------------- 1180 1181 INTEGER :: & 1182 nmap, & ! identifies which mapping array to resize 1183 increment ! the number of links to add(subtract) to arrays 1184 1185 !----------------------------------------------------------------------- 1186 ! local variables 1187 !----------------------------------------------------------------------- 1188 1189 INTEGER :: & 1190 ierr, & ! error flag 1191 mxlinks ! size of link arrays 1192 1193 INTEGER, DIMENSION(:), ALLOCATABLE :: & 1194 add1_tmp, & ! temp array for resizing address arrays 1195 add2_tmp ! temp array for resizing address arrays 1196 ! 1197 ! temp array for resizing weight arrays 1198 ! 1199 REAL*8, DIMENSION(:,:), ALLOCATABLE :: wts_tmp 1200 ! 1201 !----------------------------------------------------------------------- 1202 !*** 1203 !*** allocate temporaries to hold original values 1204 !*** 1205 mxlinks = SIZE(grid1_add_map1) 1206 ALLOCATE (add1_tmp(mxlinks), add2_tmp(mxlinks), & 1207 wts_tmp(num_wts,mxlinks)) 1208 1209 add1_tmp = grid1_add_map1 1210 add2_tmp = grid2_add_map1 1211 wts_tmp = wts_map1 1212 1213 !*** 1214 !*** deallocate originals and increment max_links then 1215 !*** reallocate arrays at new size 1216 !*** 1217 1218 DEALLOCATE (grid1_add_map1, grid2_add_map1, wts_map1) 1219 max_links_map1 = mxlinks + increment 1220 ALLOCATE (grid1_add_map1(max_links_map1), & 1221 grid2_add_map1(max_links_map1), & 1222 wts_map1(num_wts,max_links_map1)) 1223 !*** 1224 !*** restore original values from temp arrays and 1225 !*** deallocate temps 1226 !*** 1227 mxlinks = MIN(mxlinks, max_links_map1) 1228 grid1_add_map1(1:mxlinks) = add1_tmp (1:mxlinks) 1229 grid2_add_map1(1:mxlinks) = add2_tmp (1:mxlinks) 1230 wts_map1 (:,1:mxlinks) = wts_tmp(:,1:mxlinks) 1231 DEALLOCATE(add1_tmp, add2_tmp, wts_tmp) 1232 1233 !----------------------------------------------------------------------- 1234 ! 1235 END SUBROUTINE resize_remap_vars 1236 ! 1237 !************************************************************************ 1238 ! 1239 END MODULE bilinear_interp 1240 1241 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1242 -
utils/tools/DOMAINcfg/src/dom_oce.F90
r12414 r13204 41 41 REAL(wp), PUBLIC :: e3zps_min !: miminum thickness for partial steps (meters) 42 42 REAL(wp), PUBLIC :: e3zps_rat !: minimum thickness ration for partial steps 43 INTEGER , PUBLIC :: nn_closea !: =0 suppress closed sea/lake from the ORCA domain or not (=1) 43 44 44 45 INTEGER, PUBLIC :: nn_interp 45 CHARACTER(LEN= 132), PUBLIC :: cn_topo46 CHARACTER(LEN=200), PUBLIC :: cn_topo 46 47 CHARACTER(LEN=132), PUBLIC :: cn_bath 47 48 CHARACTER(LEN=132), PUBLIC :: cn_lon 48 49 CHARACTER(LEN=132), PUBLIC :: cn_lat 50 REAL(wp), PUBLIC :: rn_scale 49 51 50 52 LOGICAL, PUBLIC :: lzoom = .FALSE. !: zoom flag … … 93 95 !! ---------------------------- 94 96 ! !!* Namelist namdom : time & space domain * 95 LOGICAL , PUBLIC :: ln_linssh !: =T linear free surface ==>> model level are fixed in time96 97 LOGICAL , PUBLIC :: ln_meshmask !: =T create a mesh-mask file (mesh_mask.nc) 97 98 REAL(wp), PUBLIC :: rn_isfhmin !: threshold to discriminate grounded ice to floating ice … … 144 145 INTEGER , PUBLIC :: narea !: number for local area 145 146 INTEGER , PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries 146 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:) !: mark i-direction local boundaries for BDY open boundaries147 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:) !: mark j-direction local boundaries for BDY open boundaries148 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:) !: mark i-direction of neighbours local boundaries for BDY open boundaries149 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:) !: mark j-direction of neighbours local boundaries for BDY open boundaries150 147 151 148 INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4) … … 279 276 #if defined key_agrif 280 277 LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .TRUE. !: agrif flag 278 LOGICAL, PUBLIC :: lk_south, lk_north, lk_west, lk_east !: Child grid boundaries (interpolation or not) 281 279 #else 282 280 LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE. !: agrif flag … … 326 324 & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(3) ) 327 325 ! 328 ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , STAT=ierr(4) ) 326 ! ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , & 327 ! & gdept_b(jpi,jpj,jpk) , gdepw_b(jpi,jpj,jpk) , & 328 ! & gdept_n(jpi,jpj,jpk) , gdepw_n(jpi,jpj,jpk) , gde3w_n(jpi,jpj,jpk) , STAT=ierr(4) ) 329 330 ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk), STAT=ierr(4) ) 331 332 ! 333 ! ALLOCATE( e3t_0(jpi,jpj,jpk) , e3u_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , & 334 ! & e3t_b(jpi,jpj,jpk) , e3u_b(jpi,jpj,jpk) , e3v_b(jpi,jpj,jpk) , e3w_b(jpi,jpj,jpk) , & 335 ! & e3t_n(jpi,jpj,jpk) , e3u_n(jpi,jpj,jpk) , e3v_n(jpi,jpj,jpk) , e3f_n(jpi,jpj,jpk) , e3w_n(jpi,jpj,jpk) , & 336 ! & e3t_a(jpi,jpj,jpk) , e3u_a(jpi,jpj,jpk) , e3v_a(jpi,jpj,jpk) , & 337 ! ! ! 338 ! & e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , & 339 ! & e3uw_b(jpi,jpj,jpk) , e3vw_b(jpi,jpj,jpk) , & 340 ! & e3uw_n(jpi,jpj,jpk) , e3vw_n(jpi,jpj,jpk) , STAT=ierr(5) ) 341 342 ! 343 ! ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , & 344 ! & hu_b(jpi,jpj) , hv_b(jpi,jpj) , r1_hu_b(jpi,jpj) , r1_hv_b(jpi,jpj) , & 345 ! & ht_n(jpi,jpj) , hu_n(jpi,jpj) , hv_n(jpi,jpj) , r1_hu_n(jpi,jpj) , r1_hv_n(jpi,jpj) , & 346 ! & hu_a(jpi,jpj) , hv_a(jpi,jpj) , r1_hu_a(jpi,jpj) , r1_hv_a(jpi,jpj) , STAT=ierr(6) ) 329 347 ! 330 348 ALLOCATE( e3t_0 (jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0(jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , & 331 & e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , STAT=ierr(5) ) 349 & e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , STAT=ierr(5) ) 332 350 ! 333 351 ALLOCATE( gdept_1d(jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) ,gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(6) ) 334 352 ! 335 ALLOCATE( bathy(jpi,jpj),mbathy(jpi,jpj), tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 353 ALLOCATE( bathy(jpi,jpj),mbathy(jpi,jpj), tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 336 354 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , & 337 355 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(7) ) … … 340 358 & risfdep(jpi,jpj) , mikv(jpi,jpj) , mikf(jpi,jpj) , STAT=ierr(8) ) 341 359 ! 342 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 360 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 343 361 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , wmask(jpi,jpj,jpk) , STAT=ierr(9) ) 344 362 ! … … 351 369 ALLOCATE( msk_opnsea (jpi,jpj), msk_csundef (jpi,jpj), & 352 370 & msk_csglo (jpi,jpj), msk_csrnf (jpi,jpj), msk_csemp (jpi,jpj), & 353 & msk_csgrpglo(jpi,jpj), msk_csgrprnf(jpi,jpj), msk_csgrpemp(jpi,jpj), STAT=ierr(11) ) 354 ! 371 & msk_csgrpglo(jpi,jpj), msk_csgrprnf(jpi,jpj), msk_csgrpemp(jpi,jpj), STAT=ierr(11) ) ! 355 372 dom_oce_alloc = MAXVAL(ierr) 356 373 ! -
utils/tools/DOMAINcfg/src/domain.F90
r12870 r13204 62 62 !! - 1D configuration, move Coriolis, u and v at T-point 63 63 !!---------------------------------------------------------------------- 64 INTEGER :: jk ! dummy loop indices 65 INTEGER :: iconf = 0 ! local integers 66 REAL(wp), POINTER, DIMENSION(:,:) :: z1_hu_0, z1_hv_0 67 INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level 68 !!---------------------------------------------------------------------- 64 69 ! 65 70 IF(lwp) THEN … … 71 76 ! !== Reference coordinate system ==! 72 77 ! 73 CALL dom_nam ! read namelist ( namrun, namdom ) 74 ! 75 CALL dom_hgr ! Horizontal mesh 76 ! 77 CALL dom_zgr ! Vertical mesh and bathymetry 78 ! 79 CALL dom_msk ! compute mask (needed by write_cfg) 80 ! 81 IF ( ln_domclo ) CALL dom_clo ! Closed seas and lake 78 CALL dom_nam ! read namelist ( namrun, namdom ) 79 ! CALL dom_clo ! Closed seas and lake 80 81 CALL dom_hgr ! Horizontal mesh 82 CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry 83 CALL dom_msk( ik_top, ik_bot ) ! Masks 84 ! 82 85 ! 83 86 CALL dom_ctl ! print extrema of masked scale factors 84 87 ! 88 #if ! defined key_agrif 85 89 CALL cfg_write ! create the configuration file 90 #endif 86 91 ! 87 92 END SUBROUTINE dom_init … … 98 103 !!---------------------------------------------------------------------- 99 104 USE ioipsl 100 NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & 101 nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl , & 102 & nn_it000, nn_itend , nn_date0 , nn_time0 , nn_leapy , nn_istate , & 103 & nn_stock, nn_write , ln_mskland , ln_clobber , nn_chunksz, nn_euler , & 105 NAMELIST/namrun/ cn_exp , & 106 & nn_it000, nn_itend , nn_date0 , nn_time0 , nn_leapy , & 107 & ln_mskland , ln_clobber , nn_chunksz, & 104 108 & ln_cfmeta, ln_iscpl 105 NAMELIST/namdom/ nn_bathy, cn_topo, cn_bath, cn_lon, cn_lat, nn_interp, & 106 & rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin, & 107 & rn_atfp , rn_rdt , ln_crs , jphgr_msh , & 109 110 NAMELIST/namdom/ ln_read_cfg, nn_bathy, cn_domcfg, cn_topo, cn_bath, cn_lon, cn_lat, rn_scale, nn_interp, & 111 & rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin, & 112 & rn_atfp , rn_rdt , ln_crs , jphgr_msh , & 108 113 & ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, & 109 114 & ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, & 110 115 & ppa2, ppkth2, ppacr2 111 112 113 116 114 117 INTEGER :: ios ! Local integer output status for namelist read … … 137 140 138 141 cexper = cn_exp 139 nrstdt = nn_rstctl140 142 nit000 = nn_it000 141 143 nitend = nn_itend 142 144 ndate0 = nn_date0 143 145 nleapy = nn_leapy 144 ninist = nn_istate 145 nstock = nn_stock 146 nstocklist = nn_stocklist 147 nwrite = nn_write 148 neuler = nn_euler 149 IF ( neuler == 1 .AND. .NOT. ln_rstart ) THEN 150 WRITE(ctmp1,*) 'ln_rstart =.FALSE., nn_euler is forced to 0 ' 151 CALL ctl_warn( ctmp1 ) 152 neuler = 0 153 ENDIF 154 155 ! ! control of output frequency 156 IF ( nstock == 0 .OR. nstock > nitend ) THEN 157 WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend 158 CALL ctl_warn( ctmp1 ) 159 nstock = nitend 160 ENDIF 161 IF ( nwrite == 0 ) THEN 162 WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend 163 CALL ctl_warn( ctmp1 ) 164 nwrite = nitend 165 ENDIF 166 167 168 169 170 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 171 CASE ( 1 ) 172 CALL ioconf_calendar('gregorian') 173 IF(lwp) WRITE(numout,*) ' The IOIPSL calendar is "gregorian", i.e. leap year' 174 CASE ( 0 ) 175 CALL ioconf_calendar('noleap') 176 IF(lwp) WRITE(numout,*) ' The IOIPSL calendar is "noleap", i.e. no leap year' 177 CASE ( 30 ) 178 CALL ioconf_calendar('360d') 179 IF(lwp) WRITE(numout,*) ' The IOIPSL calendar is "360d", i.e. 360 days in a year' 180 END SELECT 181 182 183 146 147 ! 148 cn_topo ='' 149 cn_bath ='' 150 cn_lon ='' 151 cn_lat ='' 152 rn_scale = 1. 184 153 185 154 REWIND( numnam_ref ) ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) … … 193 162 IF(lwm) WRITE ( numond, namdom ) 194 163 ! 164 165 166 195 167 IF(lwp) THEN 196 168 WRITE(numout,*) … … 198 170 WRITE(numout,*) ' flag read/compute bathymetry nn_bathy = ', nn_bathy 199 171 IF( nn_bathy == 2 ) THEN 200 WRITE(numout,*) ' compute bathymetry from file cn_topo = ', cn_topo 172 WRITE(numout,*) ' compute bathymetry from file cn_topo = ' , cn_topo 173 WRITE(numout,*) ' bathymetry name in file cn_bath = ' , cn_bath 174 WRITE(numout,*) ' longitude name in file cn_lon = ' , cn_lon 175 WRITE(numout,*) ' latitude name in file cn_lat = ' , cn_lat 176 WRITE(numout,*) ' bathmetry scale factor rn_scale = ' , rn_scale 201 177 ENDIF 202 178 WRITE(numout,*) ' Depth (if =0 bathy=jpkm1) rn_bathy = ', rn_bathy … … 255 231 !!---------------------------------------------------------------------- 256 232 ! 233 #undef CHECK_DOM 234 #ifdef CHECK_DOM 257 235 IF(lk_mpp) THEN 258 236 CALL mpp_minloc( 'dom_ctl', e1t(:,:), tmask_i(:,:), ze1min, iloc ) … … 292 270 WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2 293 271 ENDIF 272 #endif 294 273 ! 295 274 ! check that all processes are still there... If some process have an error, … … 426 405 CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF) 427 406 CALL iom_rstput( 0, 0, inum, 'isf_draft' , risfdep , ktype = jp_r8 ) 428 CALL iom_rstput( 0, 0, inum, 'bathy_metry' , bathy , ktype = jp_r8 ) 407 DO jj = 1,jpj 408 DO ji = 1,jpi 409 z2d (ji,jj) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj) 410 END DO 411 END DO 412 CALL iom_rstput( 0, 0, inum, 'bathy_metry' , z2d , ktype = jp_r8 ) 429 413 ! 430 414 ! !== closed sea ==! -
utils/tools/DOMAINcfg/src/dombat.F90
r12414 r13204 2 2 3 3 USE dom_oce ! ocean domain 4 ! USE closea ! closed seas5 4 ! 6 5 USE in_out_manager ! I/O manager … … 8 7 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 9 8 USE lib_mpp ! distributed memory computing library 9 #if defined key_agrif 10 10 USE agrif_modutil 11 USE agrif_parameters 12 #endif 11 13 USE bilinear_interp 12 14 … … 20 22 SUBROUTINE dom_bat 21 23 22 INTEGER :: inum, isize, jsize, id, ji, jj 24 INTEGER :: inum, id, ji, jj,ji1,jj1 25 INTEGER :: iimin,iimax,jjmin,jjmax 23 26 INTEGER :: tabdim1, tabdim2, nxhr, nyhr, nxyhr 24 27 INTEGER, DIMENSION(2) :: ddims 25 28 INTEGER, DIMENSION(3) :: status 26 INTEGER, DIMENSION(:,:), ALLOCATABLE :: trouble_points , vardep,mask_oce27 INTEGER :: iimin,iimax,jjmin,jjmax28 29 INTEGER, DIMENSION(1) :: i_min,i_max 29 INTEGER, DIMENSION(1) ::j_min,j_max 30 REAL(wp), DIMENSION(jpi,jpj) :: myglamf 31 INTEGER,DIMENSION(:) ,POINTER :: src_add,dst_add => NULL() 32 REAL(wp), DIMENSION(:) ,ALLOCATABLE :: vardep1d, lon_new1D,lat_new1D 33 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: bathy_new, lat_new, lon_new, bathy_test 34 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: coarselon, coarselat, coarsebathy 35 REAL(wp) :: Cell_lonmin, Cell_lonmax, Cell_latmin, Cell_latmax 30 INTEGER, DIMENSION(1) :: j_min,j_max 31 INTEGER, DIMENSION(:) ,ALLOCATABLE :: src_add,dst_add 32 INTEGER, DIMENSION(:,:), ALLOCATABLE :: trouble_points , vardep,mask_oce 33 REAL(wp) ,DIMENSION(jpi,jpj):: Cell_lonmin, Cell_lonmax, Cell_latmin, Cell_latmax 34 REAL(wp) ::zdel 35 REAL(wp), DIMENSION(:) , ALLOCATABLE :: lon_new1D , lat_new1D, vardep1d 36 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: coarselon, coarselat, coarsebathy, bathy_test 37 REAL(wp), DIMENSION(:,:),ALLOCATABLE :: matrix,interpdata 38 LOGICAL :: lonlat_2D, ln_pacifiq 36 39 LOGICAL :: identical_grids 37 40 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: masksrc 38 REAL *8, DIMENSION(:,:),POINTER :: matrix,interpdata => NULL()39 LOGICAL :: lonlat_2D40 41 REAL(wp), DIMENSION(jpi,jpj) :: zglamt, zgphi, zglamu, zglamv, zglamf 42 REAL(wp) :: zshift 43 41 44 CHARACTER(32) :: bathyfile, bathyname, lonname,latname 42 43 lonlat_2D=.false.44 45 45 46 bathyfile=TRIM(cn_topo) … … 49 50 50 51 CALL iom_open( bathyfile, inum, lagrif=.FALSE. ) 52 53 ! check if lon/lat are 2D arrays 54 id = iom_varid( inum, lonname, ddims ) 55 IF (ddims(2)==0) THEN 56 lonlat_2D = .FALSE. 57 ELSE 58 lonlat_2D = .TRUE. 59 ENDIF 60 51 61 id = iom_varid( inum, bathyname, ddims ) 52 62 ln_pacifiq = .FALSE. 63 zglamt(:,:) = glamt(:,:) 64 zglamu(:,:) = glamu(:,:) 65 zglamv(:,:) = glamv(:,:) 66 zglamf(:,:) = glamf(:,:) 67 68 IF( glamt(1,1) .GT. glamt(jpi,jpj) ) ln_pacifiq =.false. 69 70 zshift = 0. 71 IF( ln_pacifiq ) THEN 72 zshift = 0.!Abs(minval(glamt)) +0.1 73 WHERE ( glamt < 0 ) 74 zglamt = zglamt + zshift + 360. 75 END WHERE 76 WHERE ( glamu < 0 ) 77 zglamu = zglamu + zshift +360. 78 END WHERE 79 WHERE ( glamv < 0 ) 80 zglamv = zglamv + zshift +360. 81 END WHERE 82 WHERE ( glamf < 0 ) 83 zglamf = zglamf + zshift +360. 84 END WHERE 85 ENDIF 86 53 87 status=-1 54 ALLOCATE(lon_new (ddims(1),ddims(2)), STAT=status(1))55 ALLOCATE(lat_new (ddims(1),ddims(2)), STAT=status(2))56 ALLOCATE(bathy_new(ddims(1),ddims(2)), STAT=status(3))57 IF( sum(status) /= 0 ) CALL ctl_stop( 'STOP', 'dom_bat : unable to allocate arrays' )58 88 59 89 IF (lonlat_2D) THEN 60 CALL iom_get ( inum, jpdom_unknown, lonname, lon_new ) 61 CALL iom_get ( inum, jpdom_unknown, latname, lat_new ) 90 ! here implicitly it's old topo database (orca format) 91 ALLOCATE(coarselon (ddims(1),ddims(2)), STAT=status(1)) 92 ALLOCATE(coarselat (ddims(1),ddims(2)), STAT=status(2)) 93 ALLOCATE(coarsebathy(ddims(1),ddims(2)), STAT=status(3)) 94 IF( sum(status) /= 0 ) CALL ctl_stop( 'STOP', 'dom_bat : unable to allocate arrays' ) 95 CALL iom_get ( inum, jpdom_unknown, lonname, coarselon ) 96 CALL iom_get ( inum, jpdom_unknown, latname, coarselat ) 97 CALL iom_get ( inum, jpdom_unknown, bathyname, coarsebathy ) 98 CALL iom_close (inum) 99 IF( ln_pacifiq ) THEN 100 ! WHERE(coarselon < 0.00001) 101 coarselon = Coarselon + zshift 102 ! END WHERE 103 ENDIF 104 ! equivalent to new database 62 105 ELSE 63 ALLOCATE(lon_new1D(ddims(1)), lat_new1D(ddims(2))) 64 CALL iom_get ( inum, jpdom_unknown, lonname, lon_new1D ) 65 CALL iom_get ( inum, jpdom_unknown, latname, lat_new1D ) 66 DO ji=1, ddims(1) 67 lon_new(ji,:)=lon_new1D(ji) 68 ENDDO 69 DO ji=1, ddims(2) 70 lat_new(:,ji)=lat_new1D(ji) 71 ENDDO 106 ALLOCATE(lon_new1D(ddims(1)), lat_new1D(ddims(2))) 107 CALL iom_get ( inum, jpdom_unknown, lonname, lon_new1D ) 108 CALL iom_get ( inum, jpdom_unknown, latname, lat_new1D ) 109 IF( ln_pacifiq ) THEN 110 WHERE(lon_new1D < 0.00001) 111 lon_new1D = lon_new1D +360.!zshift 112 END WHERE 113 ENDIF 114 zdel = 0.00 115 IF( MAXVAL(zglamf) > 180 + zshift ) THEN 116 ! 117 ! WHERE( lon_new1D < 0 ) 118 ! lon_new1D = lon_new1D + 360. 119 ! END WHERE 120 ! 121 i_min = MAXLOC(lon_new1D,mask = lon_new1D < MINVAL(zglamf(1:jpi-1,1:jpj-1)) ) 122 i_max = MINLOC(lon_new1D,mask = lon_new1D > MAXVAL(zglamf(1:jpi-1,1:jpj-1)) ) 123 j_min = MAXLOC(lat_new1D,mask = lat_new1D < MINVAL( gphif(1:jpi-1,1:jpj-1)) ) 124 j_max = MINLOC(lat_new1D,mask = lat_new1D > MAXVAL( gphif(1:jpi-1,1:jpj-1)) ) 125 ! 126 tabdim1 = ( SIZE(lon_new1D) - i_min(1) + 1 ) + i_max(1) 127 ! 128 IF(j_min(1)-2 >= 1 .AND. j_max(1)+3 <= SIZE(lat_new1D,1) ) THEN 129 j_min(1) = j_min(1) - 2 130 j_max(1) = j_max(1)+ 3 131 ENDIF 132 tabdim2 = j_max(1) - j_min(1) + 1 133 ! 134 ALLOCATE(coarselon (tabdim1,tabdim2), STAT=status(1)) 135 ALLOCATE(coarselat (tabdim1,tabdim2), STAT=status(2)) 136 ALLOCATE(Coarsebathy(tabdim1,tabdim2), STAT=status(3)) 137 138 IF( SUM(status) /= 0 ) CALL ctl_stop( 'STOP', 'dom_bat : unable to allocate arrays' ) 139 ! 140 DO ji = 1,tabdim1 141 coarselat(ji,:) = lat_new1D(j_min(1):j_max(1)) 142 END DO 143 144 ! 145 DO jj = 1, tabdim2 146 coarselon(1:SIZE(lon_new1D)-i_min(1)+1 ,jj) = lon_new1D(i_min(1):SIZE(lon_new1D)) 147 coarselon(2+SIZE(lon_new1D)-i_min(1):tabdim1,jj) = lon_new1D(1:i_max(1)) 148 END DO 149 ! 150 CALL iom_get(inum, jpdom_unknown, bathyname,coarsebathy(1:SIZE(lon_new1D)-i_min(1)+1,:), & 151 kstart=(/i_min(1),j_min(1)/), kcount=(/SIZE(lon_new1D)-i_min(1)+1,tabdim2/)) ! +1? 152 ! 153 CALL iom_get(inum, jpdom_unknown, bathyname,coarsebathy(2+SIZE(lon_new1D)-i_min(1):tabdim1,:), & 154 kstart=(/1,j_min(1)/),kcount=(/i_max(1),tabdim2/)) 155 ! 156 ELSE 157 ! WHERE( lon_new1D > (180. + zshift) ) lon_new1D = lon_new1D - 360. 158 i_min = MAXLOC(lon_new1D,mask = lon_new1D < MINVAL(zglamf)-zdel) 159 i_max = MINLOC(lon_new1D,mask = lon_new1D > MAXVAL(zglamf)+zdel) 160 j_min = MAXLOC(lat_new1D,mask = lat_new1D < MINVAL(gphif)-zdel) 161 j_max = MINLOC(lat_new1D,mask = lat_new1D > MAXVAL(gphif)+zdel) 162 163 i_min(1)=max(i_min(1),1) 164 ! 165 IF(i_min(1)-2 >= 1 .AND. i_max(1)+3 <= SIZE(lon_new1D,1) ) THEN 166 i_min(1) = i_min(1)-2 167 i_max(1) = i_max(1)+3 168 ENDIF 169 tabdim1 = i_max(1) - i_min(1) + 1 170 ! 171 IF(j_min(1)-2 >= 1 .AND. j_max(1)+3 <= SIZE(lat_new1D,1) ) THEN 172 j_min(1) = j_min(1)-2 173 j_max(1) = j_max(1)+3 174 ENDIF 175 tabdim2 = j_max(1) - j_min(1) + 1 176 ! 177 ALLOCATE(coarselon (tabdim1,tabdim2), STAT=status(1)) 178 ALLOCATE(coarselat (tabdim1,tabdim2), STAT=status(2)) 179 ALLOCATE(coarsebathy(tabdim1,tabdim2), STAT=status(3)) 180 181 IF( SUM(status) /= 0 ) CALL ctl_stop( 'STOP', 'dom_bat : unable to allocate arrays' ) 182 ! 183 DO jj = 1,tabdim2 184 coarselon(:,jj) = lon_new1D(i_min(1):i_max(1)) 185 END DO 186 ! 187 DO ji = 1,tabdim1 188 coarselat(ji,:) = lat_new1D(j_min(1):j_max(1)) 189 END DO 190 ! 191 CALL iom_get(inum,jpdom_unknown,bathyname,coarsebathy, & 192 & kstart=(/i_min(1),j_min(1)/),kcount=(/tabdim1,tabdim2/)) 193 ! 194 ENDIF ! > 180 195 196 DEALLOCATE(lon_new1D) ; DEALLOCATE(lat_new1D) 197 CALL iom_close (inum) 198 199 coarsebathy = coarsebathy *rn_scale 200 ! reset land to 0 201 WHERE (coarsebathy < 0.) 202 coarsebathy=0. 203 ENDWHERE 204 205 ENDIF ! external 206 207 IF(lwp) THEN 208 WRITE(numout,*) 'Interpolation of high resolution bathymetry on child grid' 209 IF( nn_interp == 0 ) THEN 210 WRITE(numout,*) 'Arithmetic average ...' 211 ELSE IF( nn_interp == 1 ) THEN 212 WRITE(numout,*) 'Median average ...' 213 ELSE IF( nn_interp == 2 ) THEN 214 WRITE(numout,*) 'Bilinear interpolation ...' 215 ELSE 216 WRITE(*,*) 'bad value for nn_interp variable ( must be 0,1 or 2 )' 217 STOP 218 ENDIF 72 219 ENDIF 73 CALL iom_get ( inum, jpdom_unknown, bathyname, bathy_new ) 74 CALL iom_close (inum) 75 WHERE (bathy_new > 0.) 76 bathy_new=0. 77 ENDWHERE 78 bathy_new=-bathy_new 79 80 ! Eventually add here a pre-selection of the area (coarselon/lat) 81 i_min=10 ; j_min=10 82 i_max= ddims(1)-10 ; j_max=ddims(2)-10 83 84 tabdim1 = i_max(1) - i_min(1) + 1 85 tabdim2 = j_max(1) - j_min(1) + 1 86 ! 87 88 ALLOCATE(coarselon(tabdim1,tabdim2)) 89 ALLOCATE(coarselat(tabdim1,tabdim2)) 90 ALLOCATE(coarsebathy(tabdim1,tabdim2)) 91 ! 92 WHERE( lon_new < 0. ) lon_new = lon_new + 360. 93 myglamf=glamf 94 WHERE( myglamf < 0. ) myglamf = myglamf + 360. 95 96 coarselat(:,:) = lat_new (i_min(1):i_max(1), j_min(1):j_max(1)) 97 coarselon (:,:) = lon_new (i_min(1):i_max(1), j_min(1):j_max(1)) 98 coarsebathy(:,:) = bathy_new(i_min(1):i_max(1), j_min(1):j_max(1)) 99 100 IF( nn_interp == 0 .OR. nn_interp == 1 ) THEN ! arithmetic or median averages 101 ! ! ----------------------------- 102 ALLOCATE(trouble_points(jpi,jpj)) 103 trouble_points(:,:) = 0 104 ! 105 DO jj = 2, jpj 106 DO ji = 2, jpi 107 ! 108 ! fine grid cell extension 109 Cell_lonmin = MIN(myglamf(ji-1,jj-1),myglamf(ji,jj-1),myglamf(ji,jj),myglamf(ji-1,jj)) 110 Cell_lonmax = MAX(myglamf(ji-1,jj-1),myglamf(ji,jj-1),myglamf(ji,jj),myglamf(ji-1,jj)) 111 Cell_latmin = MIN(gphif(ji-1,jj-1),gphif(ji,jj-1),gphif(ji,jj),gphif(ji-1,jj)) 112 Cell_latmax = MAX(gphif(ji-1,jj-1),gphif(ji,jj-1),gphif(ji,jj),gphif(ji-1,jj)) 113 ! 114 ! look for points in G0 (bathy dataset) contained in the fine grid cells 115 iimin = 1 116 DO WHILE( coarselon(iimin,1) < Cell_lonmin ) 117 iimin = iimin + 1 118 ENDDO 119 ! 120 jjmin = 1 121 DO WHILE( coarselat(iimin,jjmin) < Cell_latmin ) 122 jjmin = jjmin + 1 123 ENDDO 124 ! 125 iimax = iimin 126 DO WHILE( coarselon(iimax,1) <= Cell_lonmax ) 127 iimax = iimax + 1 128 iimax = MIN( iimax,SIZE(coarsebathy,1)) 129 ENDDO 130 ! 131 jjmax = jjmin 132 DO WHILE( coarselat(iimax,jjmax) <= Cell_latmax ) 133 jjmax = jjmax + 1 134 jjmax = MIN( jjmax,SIZE(coarsebathy,2)) 135 ENDDO 136 ! 137 IF( .NOT. Agrif_Root() ) THEN 138 iimax = iimax-1 139 jjmax = jjmax-1 140 ELSE 141 iimax = MAX(iimin,iimax-1) 142 jjmax = MAX(jjmin,jjmax-1) 143 ENDIF 144 ! 145 iimin = MAX( iimin,1 ) 146 jjmin = MAX( jjmin,1 ) 147 iimax = MIN( iimax,SIZE(coarsebathy,1)) 148 jjmax = MIN( jjmax,SIZE(coarsebathy,2)) 149 150 nxhr = iimax - iimin + 1 151 nyhr = jjmax - jjmin + 1 152 153 154 IF( nxhr == 0 .OR. nyhr == 0 ) THEN 155 ! 156 trouble_points(ji,jj) = 1 157 ! 158 ELSE 159 ! 160 ALLOCATE( vardep(nxhr,nyhr), mask_oce(nxhr,nyhr) ) 161 vardep(:,:) = coarsebathy(iimin:iimax,jjmin:jjmax) 162 ! 163 WHERE( vardep(:,:) .GT. 0. ) ; mask_oce = 1 ; 164 ELSEWHERE ; mask_oce = 0 ; 165 ENDWHERE 166 ! 167 nxyhr = nxhr*nyhr 168 IF( SUM(mask_oce) < 0.5*(nxyhr) ) THEN ! if more than half of the points are on land then bathy fine = 0 169 bathy(ji,jj) = 0. 170 ELSE 171 IF( nn_interp == 0 ) THEN ! Arithmetic average 172 bathy(ji,jj) = SUM( vardep(:,:) * mask_oce(:,:) ) / SUM( mask_oce(:,:) ) 173 ELSE ! Median average 174 ALLOCATE(vardep1d(nxyhr)) 175 vardep1d = RESHAPE(vardep,(/ nxyhr /) ) 176 !!CALL ssort(vardep1d,nxyhr) 177 CALL quicksort(vardep1d,1,nxyhr) 178 ! 179 ! Calculate median 180 IF (MOD(nxyhr,2) .NE. 0) THEN 181 bathy(ji,jj) = vardep1d( nxyhr/2 + 1 ) 182 ELSE 183 bathy(ji,jj) = 0.5 * ( vardep1d(nxyhr/2) + vardep1d(nxyhr/2+1) ) 184 END IF 185 DEALLOCATE(vardep1d) 186 ENDIF 187 ENDIF 188 DEALLOCATE (mask_oce,vardep) 189 ! 190 ENDIF 191 ENDDO 192 ENDDO 193 194 IF( SUM( trouble_points ) > 0 ) THEN 195 PRINT*,'too much empty cells, proceed to bilinear interpolation' 196 nn_interp = 2 197 stop 198 ENDIF 199 ENDIF 200 201 #undef MYTEST 202 #ifdef MYTEST 203 IF( nn_interp == 2) THEN ! Bilinear interpolation 204 ! ! ----------------------------- 205 identical_grids = .FALSE. 206 207 IF( SIZE(coarselat,1) == jpi .AND. SIZE(coarselat,2) == jpj .AND. & 208 SIZE(coarselon,1) == jpj .AND. SIZE(coarselon,2) == jpj ) THEN 209 IF( MAXVAL( ABS(coarselat(:,:)- gphit(:,:)) ) < 0.0001 .AND. & 210 MAXVAL( ABS(coarselon(:,:)- glamt(:,:)) ) < 0.0001 ) THEN 211 PRINT*,'same grid between ', cn_topo,' and child domain' 212 bathy = bathy_new 213 identical_grids = .TRUE. 214 ENDIF 215 ENDIF 216 217 IF( .NOT. identical_grids ) THEN 218 219 ALLOCATE(masksrc(SIZE(bathy_new,1),SIZE(bathy_new,2))) 220 ALLOCATE(bathy_test(jpi,jpj)) 221 ! 222 !Where(G0%bathy_meter.le.0.00001) 223 ! masksrc = .false. 224 !ElseWhere 225 masksrc = .TRUE. 226 !End where 227 ! 228 ! compute remapping matrix thanks to SCRIP package 229 CALL get_remap_matrix(coarselat,gphit,coarselon,glamt,masksrc,matrix,src_add,dst_add) 230 CALL make_remap(bathy_new,bathy_test,jpi,jpj,matrix,src_add,dst_add) 231 ! 232 bathy = bathy_test 233 ! 234 DEALLOCATE(masksrc) 235 DEALLOCATE(bathy_test) 236 237 ENDIF 220 bathy(:,:) = 0. 221 ! 222 !------------------------------------ 223 !MEDIAN AVERAGE or ARITHMETIC AVERAGE 224 !------------------------------------ 225 ! 226 IF( nn_interp == 0 .OR. nn_interp == 1 ) THEN 227 ! 228 ALLOCATE(trouble_points(jpi,jpj)) 229 trouble_points = 0 230 ! 231 ! POINT DETECTION 232 ! 233 ! 234 DO jj = 1,jpj 235 DO ji = 1,jpi 236 ! 237 ! FINE GRID CELLS DEFINITION 238 ji1=max(ji-1,1) 239 jj1=max(jj-1,1) 240 241 ! 242 Cell_lonmin(ji,jj) = MIN(zglamf(ji1,jj1),zglamf(ji,jj1),zglamf(ji,jj),zglamf(ji1,jj)) 243 Cell_lonmax(ji,jj) = MAX(zglamf(ji1,jj1),zglamf(ji,jj1),zglamf(ji,jj),zglamf(ji1,jj)) 244 Cell_latmin(ji,jj) = MIN(gphif(ji1,jj1),gphif(ji,jj1),gphif(ji,jj),gphif(ji1,jj)) 245 Cell_latmax(ji,jj) = MAX(gphif(ji1,jj1),gphif(ji,jj1),gphif(ji,jj),gphif(ji1,jj)) 246 IF( ABS(Cell_lonmax(ji,jj) - Cell_lonmin(ji,jj) ) > 180 ) THEN 247 zdel = Cell_lonmax(ji,jj) 248 Cell_lonmax(ji,jj) = Cell_lonmin(ji,jj) 249 Cell_lonmin(ji,jj) = zdel-360 250 ENDIF 251 ! 252 ! SEARCH FOR ALL POINTS CONTAINED IN THIS CELL 253 ! 254 ! ENDDO 255 ! ENDDO 256 ! CALL lbc_lnk( 'dom_bat', Cell_lonmin, 'T', 1. ) 257 ! CALL lbc_lnk( 'dom_bat', Cell_lonmax, 'T', 1. ) 258 ! CALL lbc_lnk( 'dom_bat', Cell_latmin, 'T', 1. ) 259 ! CALL lbc_lnk( 'dom_bat', Cell_latmax, 'T', 1. ) 260 261 262 ! DO jj = 2,jpj 263 ! DO ji = 2,jpi 264 iimin = 1 265 DO WHILE( coarselon(iimin,1) < Cell_lonmin(ji,jj) ) 266 iimin = iimin + 1 267 ! IF ( iimin .LE. 1 ) THEN 268 ! iimin = 1 269 ! EXIT 270 ! ENDIF 271 ENDDO 272 ! 273 jjmin = 1 274 DO WHILE( coarselat(iimin,jjmin) < Cell_latmin(ji,jj) ) 275 jjmin = jjmin + 1 276 ! IF ( iimin .LE. 1 ) THEN 277 ! iimin = 1 278 ! EXIT 279 ! ENDIF 280 ENDDO 281 jjmin=max(1,jjmin) 282 ! 283 iimax = iimin 284 DO WHILE( coarselon(iimax,1)<= Cell_lonmax(ji,jj) ) 285 iimax = iimax + 1 286 IF ( iimax .GE. SIZE(coarsebathy,1) ) THEN 287 iimax = MIN( iimax,SIZE(coarsebathy,1)) 288 EXIT 289 ENDIF 290 ENDDO 291 ! 292 jjmax = jjmin 293 DO WHILE( coarselat(iimax,jjmax) <= Cell_latmax(ji,jj) ) 294 jjmax = jjmax + 1 295 IF ( jjmax .GE. SIZE(coarsebathy,2) ) THEN 296 jjmax = MIN( jjmax,SIZE(coarsebathy,2)) 297 EXIT 298 ENDIF 299 ENDDO 300 ! 301 ! iimax = iimax-1 302 ! jjmax = jjmax-1 303 ! 304 iimin = MAX( iimin,1 ) 305 jjmin = MAX( jjmin,1 ) 306 iimax = MIN( iimax,SIZE(coarsebathy,1)) 307 jjmax = MIN( jjmax,SIZE(coarsebathy,2)) 308 309 nxhr = iimax - iimin + 1 310 nyhr = jjmax - jjmin + 1 311 312 313 314 IF( nxhr == 0 .OR. nyhr == 0 ) THEN 315 trouble_points(ji,jj) = 1 316 ELSE 317 ALLOCATE( vardep(nxhr,nyhr) ) 318 ALLOCATE( mask_oce(nxhr,nyhr) ) 319 mask_oce = 0 320 vardep(:,:) = coarsebathy(iimin:iimax,jjmin:jjmax) 321 WHERE( vardep(:,:) .GT. 0. ) 322 mask_oce = 1 323 ENDWHERE 324 nxyhr = nxhr*nyhr 325 ! IF( SUM(mask_oce) == 0 ) THEN 326 IF( SUM(mask_oce) < 0.5*(nxhr*nyhr) ) THEN 327 bathy(ji,jj) = 0. 328 ELSE 329 IF( nn_interp == 0 ) THEN 330 ! Arithmetic average 331 bathy(ji,jj) = SUM (vardep(:,:)*mask_oce(:,:))/SUM(mask_oce) 332 ELSE 333 ! Median average 334 ! 335 ALLOCATE(vardep1d(nxhr*nyhr)) 336 vardep1d = RESHAPE(vardep,(/ nxhr*nyhr /) ) 337 ! CALL ssort(vardep1d,nxhr*nyhr) 338 CALL quicksort(vardep1d,1,nxhr*nyhr) 339 ! 340 ! Calculate median 341 ! 342 IF (MOD(SUM(mask_oce),2) .NE. 0) THEN 343 bathy(ji,jj) = vardep1d( nxyhr/2 + 1 ) 344 ELSE 345 bathy(ji,jj) =0.5 * ( vardep1d(nxyhr/2) + vardep1d(nxyhr/2+1) ) 346 END IF 347 DEALLOCATE(vardep1d) 348 ENDIF 349 ENDIF 350 DEALLOCATE (mask_oce,vardep) 351 ENDIF 352 ENDDO 353 ENDDO 354 355 IF( SUM( trouble_points ) > 0 ) THEN 356 CALL ctl_warn ('too much empty cells, proceed to bilinear interpolation') 357 nn_interp = 2 358 ENDIF 359 ENDIF 360 361 ! 362 ! create logical array masksrc 363 ! 364 IF( nn_interp == 2) THEN 365 ! 366 identical_grids = .FALSE. 367 368 # ifdef key_agrif 369 IF( Agrif_Parent(jpi) == jpi .AND. & 370 Agrif_Parent(jpj) == jpj ) THEN 371 IF( MAXVAL( ABS(coarselat(:,:)- gphit(:,:)) ) < 0.0001 .AND. & 372 MAXVAL( ABS(coarselon(:,:)- gphit(:,:)) ) < 0.0001 ) THEN 373 bathy(:,:) = coarsebathy(:,:) 374 IF(lwp) WRITE(numout,*) 'same grid between ', bathyname,' and child domain' 375 identical_grids = .TRUE. 376 ENDIF 377 ENDIF 378 # endif 379 IF( .NOT. identical_grids ) THEN 380 ALLOCATE(masksrc(SIZE(coarsebathy,1),SIZE(coarsebathy,2))) 381 ALLOCATE(bathy_test(jpi,jpj)) 382 ! 383 ! Where(G0%bathy_meter.le.0.00001) 384 ! masksrc = .false. 385 ! ElseWhere 386 ! 387 masksrc = .TRUE. 388 ! 389 ! End where 390 ! 391 ! compute remapping matrix thanks to SCRIP package 392 ! 393 CALL get_remap_matrix(coarselat,gphit, & 394 coarselon,zglamt, & 395 masksrc,matrix,src_add,dst_add) 396 CALL make_remap(coarsebathy,bathy_test,jpi,jpj, & 397 matrix,src_add,dst_add) 398 ! 399 bathy= bathy_test 400 ! 401 DEALLOCATE(masksrc) 402 DEALLOCATE(bathy_test) 403 ENDIF 238 404 ! 239 ENDIF 240 #endif 405 ENDIF 406 CALL lbc_lnk( 'dom_bat', bathy, 'T', 1. ) 407 408 ! Correct South and North 409 #if defined key_agrif 410 IF( lk_south ) THEN 411 IF( (nbondj == -1).OR.(nbondj == 2) ) THEN 412 bathy(:,1)=bathy(:,2) 413 ENDIF 414 ELSE 415 bathy(:,1) = 0. 416 ENDIF 417 #else 418 IF ((nbondj == -1).OR.(nbondj == 2)) THEN 419 bathy(:,1)=bathy(:,2) 420 ENDIF 421 #endif 422 423 IF ((nbondj == 1).OR.(nbondj == 2)) THEN 424 bathy(:,jpj)=bathy(:,jpj-1) 425 ENDIF 426 427 ! Correct West and East 428 IF (jperio /=1) THEN 429 IF ((nbondi == -1).OR.(nbondi == 2)) THEN 430 bathy(1,:)=bathy(2,:) 431 ENDIF 432 IF ((nbondi == 1).OR.(nbondi == 2)) THEN 433 bathy(jpi,:)=bathy(jpi-1,:) 434 ENDIF 435 ENDIF 436 437 241 438 END SUBROUTINE dom_bat 242 439 -
utils/tools/DOMAINcfg/src/dombat_util.f90
r12414 r13204 1 !2 1 MODULE agrif_modutil 3 2 ! -
utils/tools/DOMAINcfg/src/domcfg.f90
r12414 r13204 99 99 WRITE(numout,*) 100 100 WRITE(numout,*) ' conversion from local to global domain indices (and vise versa) done' 101 IF( nn_print >= 1 ) THEN 102 WRITE(numout,*) 103 WRITE(numout,*) ' conversion local ==> global i-index domain (mig)' 104 WRITE(numout,25) (mig(ji),ji = 1,jpi) 105 WRITE(numout,*) 106 WRITE(numout,*) ' conversion global ==> local i-index domain' 107 WRITE(numout,*) ' starting index (mi0)' 108 WRITE(numout,25) (mi0(ji),ji = 1,jpiglo) 109 WRITE(numout,*) ' ending index (mi1)' 110 WRITE(numout,25) (mi1(ji),ji = 1,jpiglo) 111 WRITE(numout,*) 112 WRITE(numout,*) ' conversion local ==> global j-index domain (mjg)' 113 WRITE(numout,25) (mjg(jj),jj = 1,jpj) 114 WRITE(numout,*) 115 WRITE(numout,*) ' conversion global ==> local j-index domain' 116 WRITE(numout,*) ' starting index (mj0)' 117 WRITE(numout,25) (mj0(jj),jj = 1,jpjglo) 118 WRITE(numout,*) ' ending index (mj1)' 119 WRITE(numout,25) (mj1(jj),jj = 1,jpjglo) 120 ENDIF 101 102 ! WRITE(numout,*) 103 ! WRITE(numout,*) ' conversion local ==> global i-index domain (mig)' 104 ! WRITE(numout,25) (mig(ji),ji = 1,jpi) 105 ! WRITE(numout,*) 106 ! WRITE(numout,*) ' conversion global ==> local i-index domain' 107 ! WRITE(numout,*) ' starting index (mi0)' 108 ! WRITE(numout,25) (mi0(ji),ji = 1,jpiglo) 109 ! WRITE(numout,*) ' ending index (mi1)' 110 ! WRITE(numout,25) (mi1(ji),ji = 1,jpiglo) 111 ! WRITE(numout,*) 112 ! WRITE(numout,*) ' conversion local ==> global j-index domain (mjg)' 113 ! WRITE(numout,25) (mjg(jj),jj = 1,jpj) 114 ! WRITE(numout,*) 115 ! WRITE(numout,*) ' conversion global ==> local j-index domain' 116 ! WRITE(numout,*) ' starting index (mj0)' 117 ! WRITE(numout,25) (mj0(jj),jj = 1,jpjglo) 118 ! WRITE(numout,*) ' ending index (mj1)' 119 ! WRITE(numout,25) (mj1(jj),jj = 1,jpjglo) 121 120 ENDIF 122 121 25 FORMAT( 100(10x,19i4,/) ) -
utils/tools/DOMAINcfg/src/domclo.F90
r12442 r13204 12 12 USE domngb ! closest point algorithm 13 13 USE phycst ! rpi, rad, ra 14 USE domut il! flood filling algorithm (fill_pool)14 USE domutl ! flood filling algorithm (fill_pool) 15 15 USE in_out_manager ! I/O manager 16 16 USE lbclnk ! lateral boundary condition - MPP exchanges … … 82 82 LOGICAL :: lskip ! flag in case lake seed on land or already filled (...) 83 83 84 NAMELIST/namclo/ rn_lon_opnsea, rn_lat_opnsea, nn_closea, sn_lake 85 84 86 !!---------------------------------------------------------------------- 85 87 !! 0 : Read namelist for closed sea definition … … 89 91 IF(lwp) WRITE(numout,*)'~~~~~~~' 90 92 91 NAMELIST/namclo/ rn_lon_opnsea, rn_lat_opnsea, nn_closea, sn_lake92 93 !!--------------------------------------------------------------------- 93 94 -
utils/tools/DOMAINcfg/src/domhgr.F90
r12414 r13204 286 286 gphi0 = zphi1 + zsin_alpha * ze1deg * REAL( jpjglo-2 , wp ) 287 287 ! 288 IF( nprint==1 .AND. lwp ) THEN 289 WRITE(numout,*) ' ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha 290 WRITE(numout,*) ' ze1deg', ze1deg, 'glam0', glam0, 'gphi0', gphi0 291 ENDIF 288 ! WRITE(numout,*) ' ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha 289 ! WRITE(numout,*) ' ze1deg', ze1deg, 'glam0', glam0, 'gphi0', gphi0 292 290 ! 293 291 DO jj = 1, jpj … … 343 341 e1_e2v(:,:) = e1v(:,:) / e2v(:,:) 344 342 345 IF( lwp .AND. nn_print >=1 .AND. .NOT.ln_rstart) THEN ! Control print : Grid informations (if not restart)343 IF( lwp ) THEN ! Control print : Grid informations (if not restart) 346 344 WRITE(numout,*) 347 345 WRITE(numout,*) ' longitude and e1 scale factors' … … 434 432 ! ------------------------------------------ 435 433 ! The equator line must be the latitude coordinate axe 436 !(PM) be carefull with nperio/jperio434 !(PM) be carefull with nperio/jperio 437 435 IF( jperio == 2 ) THEN 438 436 znorme = SQRT( SUM( gphiu(:,2) * gphiu(:,2) ) ) / REAL( jpi ) … … 455 453 ! 456 454 INTEGER :: inum ! temporary logical unit 455 CHARACTER(LEN=135) :: coordinate_filename 457 456 !!---------------------------------------------------------------------- 458 457 ! … … 463 462 ENDIF 464 463 ! 465 CALL iom_open( 'coordinates', inum ) 464 IF (ln_read_cfg) THEN 465 coordinate_filename=TRIM(cn_domcfg) 466 ELSE 467 coordinate_filename='coordinates' 468 ENDIF 469 CALL iom_open( coordinate_filename, inum ) 466 470 ! 467 471 CALL iom_get( inum, jpdom_data, 'glamt', glamt, lrowattr=ln_use_jattr ) -
utils/tools/DOMAINcfg/src/domisf.F90
r12414 r13204 14 14 !!--------------------------------------------------------------------- 15 15 USE dom_oce 16 USE domut il! flood filling algorithm16 USE domutl ! flood filling algorithm 17 17 USE domngb ! find nearest neighbourg 18 18 USE in_out_manager ! I/O manager -
utils/tools/DOMAINcfg/src/dommsk.F90
r12414 r13204 26 26 USE domisf ! domain: ice shelf 27 27 USE domwri ! domain: write the meshmask file 28 USE bdy_oce ! open boundary28 USE usrdef_fmask ! user defined fmask 29 29 ! 30 30 USE in_out_manager ! I/O manager … … 52 52 CONTAINS 53 53 54 SUBROUTINE dom_msk 54 SUBROUTINE dom_msk( k_top, k_bot ) 55 55 !!--------------------------------------------------------------------- 56 56 !! *** ROUTINE dom_msk *** … … 62 62 !! and ko_bot, the indices of the fist and last ocean t-levels which 63 63 !! are either defined in usrdef_zgr or read in zgr_read. 64 !! The velocity masks (umask, vmask )64 !! The velocity masks (umask, vmask, wmask, wumask, wvmask) 65 65 !! are deduced from a product of the two neighboring tmask. 66 66 !! The vorticity mask (fmask) is deduced from tmask taking … … 77 77 !! due to cyclic or North Fold boundaries as well as MPP halos. 78 78 !! 79 !! ** Action : tmask, umask, vmask, wmask : land/ocean mask79 !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask 80 80 !! at t-, u-, v- w, wu-, and wv-points (=0. or 1.) 81 81 !! fmask : land/ocean mask at f-point (=0., or =1., or … … 85 85 !! ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask 86 86 !!---------------------------------------------------------------------- 87 88 INTEGER, DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! first and last ocean level 87 89 ! 88 90 INTEGER :: ji, jj, jk ! dummy loop indices … … 94 96 !! 95 97 NAMELIST/namlbc/ rn_shlat, ln_vorlat 96 NAMELIST/nambdy/ ln_bdy ,nb_bdy, ln_coords_file, cn_coords_file, &97 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, &98 & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, &99 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &100 & cn_ice, nn_ice_dta, &101 & rn_ice_tem, rn_ice_sal, rn_ice_age, &102 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy103 98 !!--------------------------------------------------------------------- 104 99 ! … … 133 128 ! N.B. tmask has already the right boundary conditions since mbathy is ok 134 129 ! 130 ! tmask(:,:,:) = 0._wp 131 ! DO jk = 1, jpk 132 ! DO jj = 1, jpj 133 ! DO ji = 1, jpi 134 ! IF( ( REAL( mbathy (ji,jj) - jk, wp ) + 0.1_wp >= 0._wp ) & 135 ! & .AND. ( REAL( misfdep(ji,jj) - jk, wp ) - 0.1_wp <= 0._wp ) ) THEN 136 ! tmask(ji,jj,jk) = 1._wp 137 ! END IF 138 ! END DO 139 ! END DO 140 ! END DO 141 142 ! IF ( ln_isfsubgl ) CALL zgr_isf_subgl 143 144 ! Ocean/land mask at t-point (computed from ko_top and ko_bot) 145 ! ---------------------------- 146 ! 135 147 tmask(:,:,:) = 0._wp 136 DO jk = 1, jpk148 IF( ln_read_cfg) THEN 137 149 DO jj = 1, jpj 138 150 DO ji = 1, jpi 139 IF( ( REAL( mbathy (ji,jj) - jk, wp ) + 0.1_wp >= 0._wp ) & 140 & .AND. ( REAL( misfdep(ji,jj) - jk, wp ) - 0.1_wp <= 0._wp ) ) THEN 141 tmask(ji,jj,jk) = 1._wp 142 END IF 151 iktop = k_top(ji,jj) 152 ikbot = k_bot(ji,jj) 153 IF( iktop /= 0 ) THEN ! water in the column 154 tmask(ji,jj,iktop:ikbot ) = 1._wp 155 ENDIF 156 END DO 157 END DO 158 ELSE 159 DO jk = 1, jpk 160 DO jj = 1, jpj 161 DO ji = 1, jpi 162 IF( ( REAL( mbathy (ji,jj) - jk, wp ) + 0.1_wp >= 0._wp ) & 163 & .AND. ( REAL( misfdep(ji,jj) - jk, wp ) - 0.1_wp <= 0._wp ) ) THEN 164 tmask(ji,jj,jk) = 1._wp 165 END IF 166 END DO 143 167 END DO 144 168 END DO 145 END DO146 147 IF ( ln_isfsubgl ) CALL zgr_isf_subgl 169 IF ( ln_isfsubgl ) CALL zgr_isf_subgl 170 ENDIF 171 148 172 149 173 !SF add here lbc_lnk: bug not still understood : cause now domain configuration is read ! … … 151 175 CALL lbc_lnk( 'dommsk', tmask , 'T', 1._wp ) ! Lateral boundary conditions 152 176 153 ! Mask corrections for bdy (read in mppini2)154 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries155 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)156 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp )157 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries158 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 )159 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp )160 ! ------------------------161 IF ( ln_bdy .AND. ln_mask_file ) THEN162 CALL iom_open( cn_mask_file, inum )163 CALL iom_get ( inum, jpdom_data, 'bdy_msk', bdytmask(:,:) )164 CALL iom_close( inum )165 DO jk = 1, jpkm1166 DO jj = 1, jpj167 DO ji = 1, jpi168 tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj)169 END DO170 END DO171 END DO172 ENDIF173 174 177 ! Ocean/land mask at u-, v-, and f-points (computed from tmask) 175 178 ! ---------------------------------------- … … 272 275 #if defined key_agrif 273 276 IF( .NOT. AGRIF_Root() ) THEN 274 IF ((nbondi == 1).OR.(nbondi == 2))fmask(nlci-1 , : ,jk) = 0.e0 ! east275 IF ((nbondi == -1).OR.(nbondi == 2))fmask(1 , : ,jk) = 0.e0 ! west276 IF ((nbondj == 1).OR.(nbondj == 2)) fmask(: ,nlcj-1 ,jk) = 0.e0 ! north277 IF ((nbondj == -1).OR.(nbondj == 2)) fmask(: ,1 ,jk) = 0.e0 ! south277 IF(lk_east) fmask(nlci-1 , : ,jk) = 0.e0 ! east 278 IF(lk_west) fmask(1 , : ,jk) = 0.e0 ! west 279 IF(lk_north) fmask(: ,nlcj-1 ,jk) = 0.e0 ! north 280 IF(lk_south) fmask(: ,1 ,jk) = 0.e0 ! south 278 281 ENDIF 279 282 #endif … … 287 290 ! 288 291 ENDIF 289 ! 290 ! write out mesh mask 291 IF ( nn_msh > 0 ) CALL dom_wri 292 293 ! User defined alteration of fmask (use to reduce ocean transport in specified straits) 294 ! -------------------------------- 295 ! 296 297 CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) 292 298 ! 293 299 END SUBROUTINE dom_msk -
utils/tools/DOMAINcfg/src/domngb.F90
r12414 r13204 11 11 !!---------------------------------------------------------------------- 12 12 USE dom_oce ! ocean space and time domain 13 USE phycst14 13 ! 15 14 USE in_out_manager ! I/O manager 16 15 USE lib_mpp ! for mppsum 16 USE phycst 17 17 18 18 IMPLICIT NONE … … 46 46 INTEGER :: ik ! working level 47 47 INTEGER , DIMENSION(2) :: iloc 48 REAL(wp) :: zlon, zmini 48 49 REAL(wp), DIMENSION(jpi,jpj) :: zglam, zgphi, zmask, zdist 49 50 !!-------------------------------------------------------------------- … … 59 60 END SELECT 60 61 61 zdist = dist(plon, plat, zglam, zgphi) 62 zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360 63 zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360 64 IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270 65 IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 66 zglam(:,:) = zglam(:,:) - zlon 62 67 63 68 IF( lk_mpp ) THEN -
utils/tools/DOMAINcfg/src/domutl.F90
r12414 r13204 1 MODULE domut il1 MODULE domutl 2 2 !! 3 3 !!====================================================================== … … 54 54 INTEGER :: iim1, ijm1, ikm1 ! working integer 55 55 INTEGER :: nseed ! size of the stack 56 TYPE (idx), POINTER :: seed 56 TYPE (idx), POINTER :: seed => NULL() 57 57 !!---------------------------------------------------------------------- 58 58 ! 59 59 ! initialisation seed 60 NULLIFY(seed)60 ! NULLIFY(seed) 61 61 ! 62 62 ! create the first seed and update nseed for all processors … … 72 72 END IF 73 73 END IF 74 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domut il', nseed ) ! nseed =0 means on land => WARNING later on74 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domutl', nseed ) ! nseed =0 means on land => WARNING later on 75 75 ! 76 76 ! loop until the stack size is 0 or if the pool is larger than the critical size … … 106 106 ! 107 107 ! exchange seed 108 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domut il', nseed ) ! this is the sum of all the point check this iteration108 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domutl', nseed ) ! this is the sum of all the point check this iteration 109 109 ! 110 110 rseedmap_b(:,:,:)=rseedmap(:,:,:) 111 CALL lbc_lnk('domut il', rseedmap, 'T', 1.)111 CALL lbc_lnk('domutl', rseedmap, 'T', 1.) 112 112 ! 113 113 ! build new list of seed … … 150 150 INTEGER :: iim1, ijm1 ! working integer 151 151 INTEGER :: nseed ! size of the stack 152 TYPE (idx), POINTER :: seed 152 TYPE (idx), POINTER :: seed => NULL() 153 153 !!---------------------------------------------------------------------- 154 154 ! 155 155 ! initialisation seed 156 NULLIFY(seed)156 !NULLIFY(seed) 157 157 ! 158 158 ! create the first seed and update nseed for all processors … … 168 168 END IF 169 169 END IF 170 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domut il', nseed ) ! nseed =0 means on land => WARNING later on170 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domutl', nseed ) ! nseed =0 means on land => WARNING later on 171 171 ! 172 172 ! loop until the stack size is 0 or if the pool is larger than the critical size … … 195 195 ! 196 196 ! exchange seed 197 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domut il', nseed ) ! this is the sum of all the point check this iteration198 ! 199 CALL lbc_lnk('domut il', rseedmap, 'T', 1.)197 nseed=SUM(rseedmap); IF( lk_mpp ) CALL mpp_sum('domutl', nseed ) ! this is the sum of all the point check this iteration 198 ! 199 CALL lbc_lnk('domutl', rseedmap, 'T', 1.) 200 200 ! 201 201 ! build new list of seed … … 259 259 zpt_tmp => pt_idx%next 260 260 DEALLOCATE(pt_idx) 261 NULLIFY(pt_idx) 261 !NULLIFY(pt_idx) 262 pt_idx => NULL() 262 263 pt_idx => zpt_tmp 263 264 ELSE 264 NULLIFY(pt_idx) 265 !NULLIFY(pt_idx) 266 pt_idx => NULL() 265 267 ENDIF 266 268 END SUBROUTINE del_head_idx 267 269 ! 268 END MODULE domut il270 END MODULE domutl -
utils/tools/DOMAINcfg/src/domzgr.F90
r12414 r13204 17 17 !! 3.4 ! 2012-08 (J. Siddorn) added Siddorn and Furner stretching function 18 18 !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) modify C1D case 19 !! 3.6 ! 2014-11 (P. Mathiot and C. Harris) add ice shelf capability 19 !! 3.6 ! 2014-11 (P. Mathiot and C. Harris) add ice shelf capabilitye 20 20 !! 3.? ! 2015-11 (H. Liu) Modifications for Wetting/Drying 21 21 !!---------------------------------------------------------------------- … … 36 36 !!--------------------------------------------------------------------- 37 37 USE dom_oce ! ocean domain 38 USE depth_e3 ! depth <=> e3 38 39 ! 39 40 USE in_out_manager ! I/O manager … … 44 45 USE dombat 45 46 USE domisf 47 USE agrif_domzgr 46 48 47 49 IMPLICIT NONE … … 92 94 CONTAINS 93 95 94 SUBROUTINE dom_zgr 96 SUBROUTINE dom_zgr( k_top, k_bot ) 95 97 !!---------------------------------------------------------------------- 96 98 !! *** ROUTINE dom_zgr *** … … 109 111 !! ** Action : define gdep., e3., mbathy and bathy 110 112 !!---------------------------------------------------------------------- 113 INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices 114 ! 111 115 INTEGER :: ioptio, ibat ! local integer 112 116 INTEGER :: ios 113 117 ! 114 NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav, ln_linssh 118 INTEGER :: jk 119 REAL(wp) :: zrefdep ! depth of the reference level (~10m) 120 121 122 NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav 115 123 !!---------------------------------------------------------------------- 116 124 ! … … 124 132 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist', lwp ) 125 133 IF(lwm) WRITE ( numond, namzgr ) 134 135 IF(ln_read_cfg) THEN 136 IF(lwp) WRITE(numout,*) 137 IF(lwp) WRITE(numout,*) ' ==>>> Read vertical mesh in ', TRIM( cn_domcfg ), ' file' 138 ! 139 CALL zgr_read ( ln_zco , ln_zps , ln_sco, ln_isfcav, & 140 & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth 141 & gdept_0 , gdepw_0 , & ! gridpoints depth 142 & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors 143 & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors 144 & k_top , k_bot ) ! 1st & last ocean level 145 ! 146 !!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears 147 ! ! Compute gde3w_0 (vertical sum of e3w) 148 ! gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 149 ! DO jk = 2, jpk 150 ! gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) 151 ! END DO 152 ! 153 154 ! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top) 155 CALL zgr_top_bot( k_top, k_bot ) ! with a minimum value set to 1 156 157 ! ! deepest/shallowest W level Above/Below ~10m 158 !!gm BUG in s-coordinate this does not work! 159 zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) 160 nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 161 nla10 = nlb10 - 1 ! deepest W level Above ~10m 162 !!gm end bug 163 164 ENDIF 126 165 127 166 IF(lwp) THEN ! Control print … … 134 173 WRITE(numout,*) ' s- or hybrid z-s-coordinate ln_sco = ', ln_sco 135 174 WRITE(numout,*) ' ice shelf cavities ln_isfcav = ', ln_isfcav 136 WRITE(numout,*) ' linear free surface ln_linssh = ', ln_linssh 137 ENDIF 138 139 IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time' 175 ENDIF 140 176 141 177 ioptio = 0 ! Check Vertical coordinate options … … 150 186 IF ( ln_sco .AND. ln_isfcav ) ioptio = ioptio + 1 151 187 IF( ioptio > 0 ) CALL ctl_stop( ' Cavity not tested/compatible with full step (zco) and sigma (ln_sco) ' ) 188 189 IF(.NOT.ln_read_cfg) THEN 152 190 ! 153 191 ! Build the vertical coordinate system … … 163 201 ! ----------------------------------- 164 202 CALL zgr_bot_level ! deepest ocean level for t-, u- and v-points 203 k_bot = mbkt 165 204 CALL zgr_top_level ! shallowest ocean level for T-, U-, V- points 166 ! 167 IF( nprint == 1 .AND. lwp ) THEN 168 WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) 205 k_top = mikt 206 WHERE( bathy(:,:) <= 0._wp ) k_top(:,:) = 0 ! set k_top to zero over land 207 ENDIF 208 ! 209 IF( lwp ) THEN 210 WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) 211 WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) 169 212 WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & 170 213 & ' w ', MINVAL( gdepw_0(:,:,:) ) … … 181 224 & ' w ', MAXVAL( e3w_0(:,:,:) ) 182 225 ENDIF 226 183 227 ! 184 228 END SUBROUTINE dom_zgr 185 229 230 SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate 231 & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate 232 & pdept , pdepw , & ! 3D t & w-points depth 233 & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors 234 & pe3w , pe3uw , pe3vw , & ! - - - 235 & k_top , k_bot ) ! top & bottom ocean level 236 !!--------------------------------------------------------------------- 237 !! *** ROUTINE zgr_read *** 238 !! 239 !! ** Purpose : Read the vertical information in the domain configuration file 240 !! 241 !!---------------------------------------------------------------------- 242 LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags 243 LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag 244 REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] 245 REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] 246 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] 247 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] 248 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - 249 INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level 250 ! 251 INTEGER :: jk ! dummy loop index 252 INTEGER :: inum ! local logical unit 253 REAL(WP) :: z_zco, z_zps, z_sco, z_cav 254 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 255 !!---------------------------------------------------------------------- 256 ! 257 IF(lwp) THEN 258 WRITE(numout,*) 259 WRITE(numout,*) ' zgr_read : read the vertical coordinates in ', TRIM( cn_domcfg ), ' file' 260 WRITE(numout,*) ' ~~~~~~~~' 261 ENDIF 262 ! 263 CALL iom_open( cn_domcfg, inum ) 264 ! 265 ! !* type of vertical coordinate 266 CALL iom_get( inum, 'ln_zco' , z_zco ) 267 CALL iom_get( inum, 'ln_zps' , z_zps ) 268 CALL iom_get( inum, 'ln_sco' , z_sco ) 269 IF( z_zco == 0._wp ) THEN ; ld_zco = .false. ; ELSE ; ld_zco = .true. ; ENDIF 270 IF( z_zps == 0._wp ) THEN ; ld_zps = .false. ; ELSE ; ld_zps = .true. ; ENDIF 271 IF( z_sco == 0._wp ) THEN ; ld_sco = .false. ; ELSE ; ld_sco = .true. ; ENDIF 272 ! 273 ! !* ocean cavities under iceshelves 274 CALL iom_get( inum, 'ln_isfcav', z_cav ) 275 IF( z_cav == 0._wp ) THEN ; ld_isfcav = .false. ; ELSE ; ld_isfcav = .true. ; ENDIF 276 ! 277 ! !* vertical scale factors 278 CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , pe3t_1d ) ! 1D reference coordinate 279 CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) 280 ! 281 CALL iom_get( inum, jpdom_data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr ) ! 3D coordinate 282 CALL iom_get( inum, jpdom_data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr ) 283 CALL iom_get( inum, jpdom_data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr ) 284 CALL iom_get( inum, jpdom_data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr ) 285 CALL iom_get( inum, jpdom_data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr ) 286 CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr ) 287 CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr ) 288 ! 289 ! !* depths 290 ! !- old depth definition (obsolescent feature) 291 IF( iom_varid( inum, 'gdept_1d', ldstop = .FALSE. ) > 0 .AND. & 292 & iom_varid( inum, 'gdepw_1d', ldstop = .FALSE. ) > 0 .AND. & 293 & iom_varid( inum, 'gdept_0' , ldstop = .FALSE. ) > 0 .AND. & 294 & iom_varid( inum, 'gdepw_0' , ldstop = .FALSE. ) > 0 ) THEN 295 CALL ctl_warn( 'zgr_read : old definition of depths and scale factors used ', & 296 & ' depths at t- and w-points read in the domain configuration file') 297 CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) 298 CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) 299 CALL iom_get( inum, jpdom_data , 'gdept_0' , pdept , lrowattr=ln_use_jattr ) 300 CALL iom_get( inum, jpdom_data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr ) 301 ! 302 ELSE !- depths computed from e3. scale factors 303 CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) ! 1D reference depth 304 CALL e3_to_depth( pe3t , pe3w , pdept , pdepw ) ! 3D depths 305 IF(lwp) THEN 306 WRITE(numout,*) 307 WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' 308 WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) 309 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk ) 310 ENDIF 311 ENDIF 312 ! 313 ! !* ocean top and bottom level 314 CALL iom_get( inum, jpdom_data, 'top_level' , z2d , lrowattr=ln_use_jattr ) ! 1st wet T-points (ISF) 315 k_top(:,:) = NINT( z2d(:,:) ) 316 CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d , lrowattr=ln_use_jattr ) ! last wet T-points 317 k_bot(:,:) = NINT( z2d(:,:) ) 318 ! 319 ! reference depth for negative bathy (wetting and drying only) 320 ! IF( ll_wd ) CALL iom_get( inum, 'rn_wd_ref_depth' , ssh_ref ) 321 ! 322 CALL iom_close( inum ) 323 ! 324 END SUBROUTINE zgr_read 325 326 SUBROUTINE zgr_top_bot( k_top, k_bot ) 327 !!---------------------------------------------------------------------- 328 !! *** ROUTINE zgr_top_bot *** 329 !! 330 !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) 331 !! 332 !! ** Method : computes from k_top and k_bot with a minimum value of 1 over land 333 !! 334 !! ** Action : mikt, miku, mikv : vertical indices of the shallowest 335 !! ocean level at t-, u- & v-points 336 !! (min value = 1) 337 !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest 338 !! ocean level at t-, u- & v-points 339 !! (min value = 1 over land) 340 !!---------------------------------------------------------------------- 341 INTEGER , DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! top & bottom ocean level indices 342 ! 343 INTEGER :: ji, jj ! dummy loop indices 344 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace 345 !!---------------------------------------------------------------------- 346 ! 347 IF(lwp) WRITE(numout,*) 348 IF(lwp) WRITE(numout,*) ' zgr_top_bot : ocean top and bottom k-index of T-, U-, V- and W-levels ' 349 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' 350 ! 351 mikt(:,:) = MAX( k_top(:,:) , 1 ) ! top ocean k-index of T-level (=1 over land) 352 ! 353 mbkt(:,:) = MAX( k_bot(:,:) , 1 ) ! bottom ocean k-index of T-level (=1 over land) 354 355 ! ! N.B. top k-index of W-level = mikt 356 ! ! bottom k-index of W-level = mbkt+1 357 DO jj = 1, jpjm1 358 DO ji = 1, jpim1 359 miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) 360 mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) 361 mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) 362 ! 363 mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) 364 mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) 365 END DO 366 END DO 367 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 368 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 369 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 370 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) 371 ! 372 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 373 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 374 ! 375 END SUBROUTINE zgr_top_bot 186 376 187 377 SUBROUTINE zgr_z … … 665 855 ENDIF 666 856 667 zbathy(:,:) = FLOAT( mbathy(:,:) ) 668 CALL lbc_lnk( 'domzgr',zbathy, 'T', 1._wp ) 669 mbathy(:,:) = INT( zbathy(:,:) ) 670 857 IF( lk_mpp ) THEN 858 zbathy(:,:) = FLOAT( mbathy(:,:) ) 859 CALL lbc_lnk( 'toto',zbathy, 'T', 1._wp ) 860 mbathy(:,:) = INT( zbathy(:,:) ) 861 ENDIF 671 862 ! ! East-west cyclic boundary conditions 672 863 IF( jperio == 0 ) THEN … … 1061 1252 END SUBROUTINE zgr_zps 1062 1253 1254 1063 1255 SUBROUTINE zgr_sco 1064 1256 !!---------------------------------------------------------------------- … … 1262 1454 END DO 1263 1455 ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero 1264 CALL lbc_lnk( ' domzgr',zenv, 'T', 1._wp, 'no0' )1456 CALL lbc_lnk( 'toto',zenv, 'T', 1._wp, 'no0' ) 1265 1457 ! ! ================ ! 1266 1458 END DO ! End loop ! … … 1341 1533 hiff(:,:) = MIN( hiff(:,:), hbatf(:,:) ) 1342 1534 1343 IF( nprint == 1 .AND.lwp ) THEN1535 IF( lwp ) THEN 1344 1536 WRITE(numout,*) ' MAX val hif t ', MAXVAL( hift (:,:) ), ' f ', MAXVAL( hiff (:,:) ), & 1345 1537 & ' u ', MAXVAL( hifu (:,:) ), ' v ', MAXVAL( hifv (:,:) ) … … 1397 1589 END DO 1398 1590 END DO 1399 IF( nprint == 1 .AND.lwp ) WRITE(numout,*) ' MIN val mbathy h90 ', MINVAL( mbathy(:,:) ), &1591 IF(lwp ) WRITE(numout,*) ' MIN val mbathy h90 ', MINVAL( mbathy(:,:) ), & 1400 1592 & ' MAX ', MAXVAL( mbathy(:,:) ) 1401 1593 1402 IF( nprint == 1 .AND.lwp ) THEN ! min max values over the local domain1594 IF( lwp ) THEN ! min max values over the local domain 1403 1595 WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) 1404 1596 WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & … … 1788 1980 z_gsigt(jk) = -fssig( REAL(jk,wp) ) 1789 1981 END DO 1790 IF( nprint == 1 .AND.lwp ) WRITE(numout,*) 'z_gsigw 1 jpk ', z_gsigw(1), z_gsigw(jpk)1982 IF( lwp ) WRITE(numout,*) 'z_gsigw 1 jpk ', z_gsigw(1), z_gsigw(jpk) 1791 1983 ! 1792 1984 ! Coefficients for vertical scale factors at w-, t- levels -
utils/tools/DOMAINcfg/src/in_out_manager.F90
r12414 r13204 22 22 !!---------------------------------------------------------------------- 23 23 CHARACTER(lc) :: cn_exp !: experiment name used for output filename 24 CHARACTER(lc) :: cn_ocerst_in !: suffix of ocean restart name (input)25 CHARACTER(lc) :: cn_ocerst_indir !: restart input directory26 CHARACTER(lc) :: cn_ocerst_out !: suffix of ocean restart name (output)27 CHARACTER(lc) :: cn_ocerst_outdir !: restart output directory28 LOGICAL :: ln_rstart !: start from (F) rest or (T) a restart file29 LOGICAL :: ln_rst_list !: output restarts at list of times (T) or by frequency (F)30 INTEGER :: nn_rstctl !: control of the time step (0, 1 or 2)31 INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0)32 24 INTEGER :: nn_it000 !: index of the first time step 33 25 INTEGER :: nn_itend !: index of the last time step … … 35 27 INTEGER :: nn_time0 !: initial time of day in hhmm 36 28 INTEGER :: nn_leapy !: Leap year calendar flag (0/1 or 30) 37 INTEGER :: nn_istate !: initial state output flag (0/1)38 INTEGER :: nn_write !: model standard output frequency39 INTEGER :: nn_stock !: restart file frequency40 INTEGER, DIMENSION(10) :: nn_stocklist !: restart dump times41 29 LOGICAL :: ln_mskland !: mask land points in NetCDF outputs (costly: + ~15%) 42 30 LOGICAL :: ln_cfmeta !: output additional data to netCDF files required for compliance with the CF metadata standard … … 45 33 LOGICAL :: ln_xios_read !: use xios to read single file restart 46 34 INTEGER :: nn_wxios !: write resart using xios 0 - no, 1 - single, 2 - multiple file output 47 INTEGER :: nn_no !: Assimilation cycle48 35 49 36 #if defined key_netcdf4 … … 74 61 75 62 CHARACTER(lc) :: cexper !: experiment name used for output filename 76 INTEGER :: nrstdt !: control of the time step (0, 1 or 2)77 63 INTEGER :: nit000 !: index of the first time step 78 64 INTEGER :: nitend !: index of the last time step 79 65 INTEGER :: ndate0 !: initial calendar date aammjj 80 66 INTEGER :: nleapy !: Leap year calendar flag (0/1 or 30) 81 INTEGER :: ninist !: initial state output flag (0/1)82 INTEGER :: nwrite !: model standard output frequency83 INTEGER :: nstock !: restart file frequency84 INTEGER, DIMENSION(10) :: nstocklist !: restart dump times85 86 !!----------------------------------------------------------------------87 !! was in restart but moved here because of the OFF line... better solution should be found...88 !!----------------------------------------------------------------------89 INTEGER :: nitrst !: time step at which restart file should be written90 LOGICAL :: lrst_oce !: logical to control the oce restart write91 LOGICAL :: lrst_ice !: logical to control the ice restart write92 INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90)93 INTEGER :: numrir !: logical unit for ice restart (read)94 INTEGER :: numrow !: logical unit for ocean restart (write)95 INTEGER :: numriw !: logical unit for ice restart (write)96 INTEGER :: nrst_lst !: number of restart to output next97 98 !!----------------------------------------------------------------------99 !! output monitoring100 !!----------------------------------------------------------------------101 LOGICAL :: ln_ctl !: run control for debugging102 TYPE :: sn_ctl !: optional use structure for finer control over output selection103 LOGICAL :: l_config = .FALSE. !: activate/deactivate finer control104 ! Note if l_config is True then ln_ctl is ignored.105 ! Otherwise setting ln_ctl True is equivalent to setting106 ! all the following logicals in this structure True107 LOGICAL :: l_runstat = .FALSE. !: Produce/do not produce run.stat file (T/F)108 LOGICAL :: l_trcstat = .FALSE. !: Produce/do not produce tracer.stat file (T/F)109 LOGICAL :: l_oceout = .FALSE. !: Produce all ocean.outputs (T) or just one (F)110 LOGICAL :: l_layout = .FALSE. !: Produce all layout.dat files (T) or just one (F)111 LOGICAL :: l_mppout = .FALSE. !: Produce/do not produce mpp.output_XXXX files (T/F)112 LOGICAL :: l_mpptop = .FALSE. !: Produce/do not produce mpp.top.output_XXXX files (T/F)113 ! Optional subsetting of processor report files114 ! Default settings of 0/1000000/1 should ensure all areas report.115 ! Set to a more restrictive range to select specific areas116 INTEGER :: procmin = 0 !: Minimum narea to output117 INTEGER :: procmax = 1000000 !: Maximum narea to output118 INTEGER :: procincr = 1 !: narea increment to output119 INTEGER :: ptimincr = 1 !: timestep increment to output (time.step and run.stat)120 END TYPE sn_ctl121 122 TYPE (sn_ctl) :: sn_cfctl !: run control structure for selective output123 LOGICAL :: ln_timing !: run control for timing124 LOGICAL :: ln_diacfl !: flag whether to create CFL diagnostics125 INTEGER :: nn_print !: level of print (0 no print)126 INTEGER :: nn_ictls !: Start i indice for the SUM control127 INTEGER :: nn_ictle !: End i indice for the SUM control128 INTEGER :: nn_jctls !: Start j indice for the SUM control129 INTEGER :: nn_jctle !: End j indice for the SUM control130 INTEGER :: nn_isplt !: number of processors following i131 INTEGER :: nn_jsplt !: number of processors following j132 INTEGER :: nn_bench !: benchmark parameter (0/1)133 INTEGER :: nn_bit_cmp = 0 !: bit reproducibility (0/1)134 !135 INTEGER :: nprint, nictls, nictle, njctls, njctle, isplt, jsplt !: OLD namelist names136 137 INTEGER :: ijsplt = 1 !: nb of local domain = nb of processors138 67 139 68 !!---------------------------------------------------------------------- … … 148 77 INTEGER :: numnam_cfg = -1 !: logical unit for configuration specific namelist 149 78 INTEGER :: numond = -1 !: logical unit for Output Namelist Dynamics 150 INTEGER :: numnam_ice_ref = -1 !: logical unit for ice reference namelist151 INTEGER :: numnam_ice_cfg = -1 !: logical unit for ice reference namelist152 79 INTEGER :: numoni = -1 !: logical unit for Output Namelist Ice 153 INTEGER :: numevo_ice = -1 !: logical unit for ice variables (temp. evolution)154 80 INTEGER :: numrun = -1 !: logical unit for run statistics 155 INTEGER :: numdct_in = -1 !: logical unit for transports computing156 INTEGER :: numdct_vol = -1 !: logical unit for voulume transports output157 INTEGER :: numdct_heat = -1 !: logical unit for heat transports output158 INTEGER :: numdct_salt = -1 !: logical unit for salt transports output159 INTEGER :: numfl = -1 !: logical unit for floats ascii output160 INTEGER :: numflo = -1 !: logical unit for floats ascii output161 81 162 82 !!---------------------------------------------------------------------- … … 174 94 LOGICAL :: lwm = .FALSE. !: boolean : true on the 1st processor only (always) 175 95 LOGICAL :: lwp = .FALSE. !: boolean : true on the 1st processor only .OR. ln_ctl 176 LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area177 96 CHARACTER(lc) :: cxios_context !: context name used in xios 178 97 CHARACTER(lc) :: crxios_context !: context name used in xios to read restart -
utils/tools/DOMAINcfg/src/ioipsl.f90
r12414 r13204 9 9 USE calendar 10 10 USE stringop 11 USE fliocom12 11 13 12 END MODULE ioipsl -
utils/tools/DOMAINcfg/src/iom_nf90.F90
r12414 r13204 530 530 INTEGER :: idim3 ! id of the third dimension 531 531 ! 532 INTEGER :: nldi_save, nlei_save !:patch before we remove periodicity and close boundaries in output files533 INTEGER :: nldj_save, nlej_save !:532 ! INTEGER :: nldi_save, nlei_save !:patch before we remove periodicity and close boundaries in output files 533 ! INTEGER :: nldj_save, nlej_save !: 534 534 !--------------------------------------------------------------------- 535 535 ! … … 540 540 ! without this, issue in some model decomposition 541 541 ! seb: patch before we remove periodicity and close boundaries in output files 542 nldi_save = nldi ; nlei_save = nlei543 nldj_save = nldj ; nlej_save = nlej544 IF( nimpp == 1 ) nldi = 1545 IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi546 IF( njmpp == 1 ) nldj = 1547 IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj542 ! nldi_save = nldi ; nlei_save = nlei 543 ! nldj_save = nldj ; nlej_save = nlej 544 ! IF( nimpp == 1 ) nldi = 1 545 ! IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi 546 ! IF( njmpp == 1 ) nldj = 1 547 ! IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj 548 548 ! 549 549 ! define dimension variables if it is not already done … … 719 719 ENDIF 720 720 ! 721 nldi = nldi_save ; nlei = nlei_save722 nldj = nldj_save ; nlej = nlej_save721 ! nldi = nldi_save ; nlei = nlei_save 722 ! nldj = nldj_save ; nlej = nlej_save 723 723 ! 724 724 END SUBROUTINE iom_nf90_rp0123d -
utils/tools/DOMAINcfg/src/lbclnk.F90
r12414 r13204 7 7 !! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module 8 8 !! 3.2 ! 2009-03 (R. Benshila) External north fold treatment 9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk9 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. 10 10 !! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case 11 11 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi … … 21 21 !!---------------------------------------------------------------------- 22 22 !! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 23 !! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp24 23 !!---------------------------------------------------------------------- 25 24 USE par_oce ! ocean dynamics and tracers … … 37 36 END INTERFACE 38 37 ! 39 INTERFACE lbc_bdy_lnk40 MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d41 END INTERFACE42 !43 38 INTERFACE lbc_lnk_icb 44 39 MODULE PROCEDURE mpp_lnk_2d_icb … … 47 42 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 48 43 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 49 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions50 44 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 51 45 … … 69 63 !! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh 70 64 !! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh 71 !! lbc_bdy_lnk : set the lateral BDY boundary condition72 65 !!---------------------------------------------------------------------- 73 66 USE dom_oce ! ocean space and time domain … … 88 81 END INTERFACE 89 82 ! 90 INTERFACE lbc_bdy_lnk91 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d92 END INTERFACE93 !94 83 INTERFACE lbc_lnk_icb 95 84 MODULE PROCEDURE lbc_lnk_2d_icb … … 98 87 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 99 88 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 100 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions101 89 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 102 90 … … 172 160 173 161 !!---------------------------------------------------------------------- 174 !! *** routine lbc_bdy_lnk_(2,3,4)d ***175 !!176 !! wrapper rountine to 'lbc_lnk_3d'. This wrapper is used177 !! to maintain the same interface with regards to the mpp case178 !!----------------------------------------------------------------------179 180 SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy )181 !!----------------------------------------------------------------------182 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine183 REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) :: pt4d ! 3D array on which the lbc is applied184 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points185 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold186 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set187 !!----------------------------------------------------------------------188 CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn)189 END SUBROUTINE lbc_bdy_lnk_4d190 191 SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy )192 !!----------------------------------------------------------------------193 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine194 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied195 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points196 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold197 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set198 !!----------------------------------------------------------------------199 CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn)200 END SUBROUTINE lbc_bdy_lnk_3d201 202 203 SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy )204 !!----------------------------------------------------------------------205 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine206 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied207 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points208 REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold209 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set210 !!----------------------------------------------------------------------211 CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn)212 END SUBROUTINE lbc_bdy_lnk_2d213 214 162 215 163 !!gm This routine should be removed with an optional halos size added in argument of generic routines -
utils/tools/DOMAINcfg/src/lib_mpp.F90
r12414 r13204 19 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 !! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm.22 21 !! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables 23 22 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations … … 87 86 PUBLIC mpp_ini_znl 88 87 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 89 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d90 88 91 89 !! * Interfaces … … 179 177 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations 180 178 181 ! timing summary report182 REAL(wp), DIMENSION(2), PUBLIC :: waiting_time = 0._wp183 REAL(wp) , PUBLIC :: compute_time = 0._wp, elapsed_time = 0._wp184 185 179 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 186 180 … … 435 429 436 430 !!---------------------------------------------------------------------- 437 !! *** routine mpp_lnk_bdy_(2,3,4)d ***438 !!439 !! * Argument : dummy argument use in mpp_lnk_... routines440 !! ptab : array or pointer of arrays on which the boundary condition is applied441 !! cd_nat : nature of array grid-points442 !! psgn : sign used across the north fold boundary443 !! kb_bdy : BDY boundary set444 !! kfld : optional, number of pt3d arrays445 !!----------------------------------------------------------------------446 !447 ! !== 2D array and array of 2D pointer ==!448 !449 # define DIM_2d450 # define ROUTINE_BDY mpp_lnk_bdy_2d451 # include "mpp_bdy_generic.h90"452 # undef ROUTINE_BDY453 # undef DIM_2d454 !455 ! !== 3D array and array of 3D pointer ==!456 !457 # define DIM_3d458 # define ROUTINE_BDY mpp_lnk_bdy_3d459 # include "mpp_bdy_generic.h90"460 # undef ROUTINE_BDY461 # undef DIM_3d462 !463 ! !== 4D array and array of 4D pointer ==!464 !465 # define DIM_4d466 # define ROUTINE_BDY mpp_lnk_bdy_4d467 # include "mpp_bdy_generic.h90"468 # undef ROUTINE_BDY469 # undef DIM_4d470 471 !!----------------------------------------------------------------------472 431 !! 473 432 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D … … 640 599 ! send y_in into todelay(idvar)%y1d with a non-blocking communication 641 600 #if defined key_mpi2 642 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)643 601 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 644 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)645 602 #else 646 603 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) … … 703 660 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 704 661 #if defined key_mpi2 705 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)706 662 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 707 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)708 663 #else 709 664 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) … … 725 680 IF( ndelayid(kid) /= -2 ) THEN 726 681 #if ! defined key_mpi2 727 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)728 682 CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! make sure todelay(kid) is received 729 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)730 683 #endif 731 684 IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d … … 1236 1189 itaille = jpimax * ( ipj + 2*kextj ) 1237 1190 ! 1238 IF( ln_timing ) CALL tic_tac(.TRUE.)1239 1191 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, & 1240 1192 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, & 1241 1193 & ncomm_north, ierr ) 1242 1194 ! 1243 IF( ln_timing ) CALL tic_tac(.FALSE.)1244 1195 ! 1245 1196 DO jr = 1, ndim_rank_north ! recover the global north array … … 1367 1318 ! ! Migrations 1368 1319 imigr = ipreci * ( jpj + 2*kextj ) 1369 !1370 IF( ln_timing ) CALL tic_tac(.TRUE.)1371 1320 ! 1372 1321 SELECT CASE ( nbondi ) … … 1388 1337 END SELECT 1389 1338 ! 1390 IF( ln_timing ) CALL tic_tac(.FALSE.)1391 !1392 1339 ! ! Write Dirichlet lateral conditions 1393 1340 iihom = jpi - nn_hls … … 1424 1371 ! ! Migrations 1425 1372 imigr = iprecj * ( jpi + 2*kexti ) 1426 !1427 IF( ln_timing ) CALL tic_tac(.TRUE.)1428 1373 ! 1429 1374 SELECT CASE ( nbondj ) … … 1444 1389 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1445 1390 END SELECT 1446 !1447 IF( ln_timing ) CALL tic_tac(.FALSE.)1448 1391 ! 1449 1392 ! ! Write Dirichlet lateral conditions … … 1586 1529 ENDIF 1587 1530 END SUBROUTINE mpp_report 1588 1589 1590 SUBROUTINE tic_tac (ld_tic, ld_global)1591 1592 LOGICAL, INTENT(IN) :: ld_tic1593 LOGICAL, OPTIONAL, INTENT(IN) :: ld_global1594 REAL(wp), DIMENSION(2), SAVE :: tic_wt1595 REAL(wp), SAVE :: tic_ct = 0._wp1596 INTEGER :: ii1597 1598 IF( ncom_stp <= nit000 ) RETURN1599 IF( ncom_stp == nitend ) RETURN1600 ii = 11601 IF( PRESENT( ld_global ) ) THEN1602 IF( ld_global ) ii = 21603 END IF1604 1605 IF ( ld_tic ) THEN1606 tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time)1607 IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic1608 ELSE1609 waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac1610 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time)1611 ENDIF1612 1613 END SUBROUTINE tic_tac1614 1615 1531 1616 1532 #else … … 1662 1578 CHARACTER(len=*),DIMENSION(:) :: ldtxt 1663 1579 CHARACTER(len=*) :: ldname 1664 INTEGER :: function_value1665 1580 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 1666 1581 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm … … 1899 1814 IF( numstp /= -1 ) CALL FLUSH(numstp ) 1900 1815 IF( numrun /= -1 ) CALL FLUSH(numrun ) 1901 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)1902 1816 ! 1903 1817 IF( cd1 == 'STOP' ) THEN -
utils/tools/DOMAINcfg/src/mpp_allreduce_generic.h90
r12414 r13204 61 61 ! 62 62 ALLOCATE(work(ipi)) 63 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)64 63 CALL mpi_allreduce( ARRAY_IN(:), work, ipi, MPI_TYPE, MPI_OPERATION, ilocalcomm, ierror ) 65 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)66 64 DO ii = 1, ipi 67 65 ARRAY_IN(ii) = work(ii) -
utils/tools/DOMAINcfg/src/mpp_lnk_generic.h90
r12414 r13204 154 154 imigr = nn_hls * jpj * ipk * ipl * ipf 155 155 ! 156 IF( ln_timing ) CALL tic_tac(.TRUE.)157 !158 156 SELECT CASE ( nbondi ) 159 157 CASE ( -1 ) … … 173 171 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 174 172 END SELECT 175 !176 IF( ln_timing ) CALL tic_tac(.FALSE.)177 173 ! 178 174 ! ! Write Dirichlet lateral conditions … … 276 272 imigr = nn_hls * jpi * ipk * ipl * ipf 277 273 ! 278 IF( ln_timing ) CALL tic_tac(.TRUE.)279 !280 274 SELECT CASE ( nbondj ) 281 275 CASE ( -1 ) … … 296 290 END SELECT 297 291 ! 298 IF( ln_timing ) CALL tic_tac(.FALSE.)299 ! ! Write Dirichlet lateral conditions300 292 ijhom = nlcj-nn_hls 301 293 ! -
utils/tools/DOMAINcfg/src/mpp_loc_generic.h90
r12414 r13204 17 17 # define MPI_OPERATION mpi_maxloc 18 18 # define LOC_OPERATION MAXLOC 19 # define ERRVAL -HUGE20 19 # endif 21 20 # if defined OPERATION_MINLOC 22 21 # define MPI_OPERATION mpi_minloc 23 22 # define LOC_OPERATION MINLOC 24 # define ERRVAL HUGE25 23 # endif 26 24 … … 44 42 ! 45 43 idim = SIZE(kindex) 44 ALLOCATE ( ilocs(idim) ) 46 45 ! 47 IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN 48 ! special case for land processors 49 zmin = ERRVAL(zmin) 50 index0 = 0 51 ELSE 52 ALLOCATE ( ilocs(idim) ) 53 ! 54 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp ) 55 zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 56 ! 57 kindex(1) = mig( ilocs(1) ) 46 ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp ) 47 zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 48 ! 49 kindex(1) = ilocs(1) + nimpp - 1 58 50 # if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 59 kindex(2) = mjg( ilocs(2) )51 kindex(2) = ilocs(2) + njmpp - 1 60 52 # endif 61 53 # if defined DIM_3d /* avoid warning when kindex has 2 elements */ 62 54 kindex(3) = ilocs(3) 63 55 # endif 64 65 66 67 56 ! 57 DEALLOCATE (ilocs) 58 ! 59 index0 = kindex(1)-1 ! 1d index starting at 0 68 60 # if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */ 69 61 index0 = index0 + jpiglo * (kindex(2)-1) 70 62 # endif 71 63 # if defined DIM_3d /* avoid warning when kindex has 2 elements */ 72 64 index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) 73 65 # endif 74 END IF75 66 zain(1,:) = zmin 76 67 zain(2,:) = REAL(index0, wp) 77 68 ! 78 IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)79 69 CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror) 80 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)81 70 ! 82 71 pmin = zaout(1,1) … … 107 96 #undef LOC_OPERATION 108 97 #undef INDEX_TYPE 109 #undef ERRVAL -
utils/tools/DOMAINcfg/src/mpp_nfd_generic.h90
r12414 r13204 95 95 l_full_nf_update = .TRUE. 96 96 97 ! Two lines update (slower but necessary to avoid different values ion identical grid points 98 IF ( l_full_nf_update .OR. & ! if coupling fields 99 ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart 100 ipj_s(:) = 2 97 ipj_s(:) = 2 101 98 102 99 ! Index of modifying lines in input … … 154 151 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 155 152 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 156 !157 ! start waiting time measurement158 IF( ln_timing ) CALL tic_tac(.TRUE.)159 153 ! 160 154 DO jr = 1, nsndto … … 208 202 ENDIF 209 203 ! 210 IF( ln_timing ) CALL tic_tac(.FALSE.)211 !212 204 ! North fold boundary condition 213 205 ! … … 248 240 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 249 241 ! 250 ! start waiting time measurement251 IF( ln_timing ) CALL tic_tac(.TRUE.)252 242 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & 253 243 & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 254 244 ! 255 ! stop waiting time measurement256 IF( ln_timing ) CALL tic_tac(.FALSE.)257 245 ! 258 246 DO jr = 1, ndim_rank_north ! recover the global north array -
utils/tools/DOMAINcfg/src/mppini.F90
r12414 r13204 17 17 !! mpp_init : Lay out the global domain over processors with/without land processor elimination 18 18 !! mpp_init_mask : Read global bathymetric information to facilitate land suppression 19 !! mpp_init_ioipsl : IOIPSL initialization in mpp20 19 !! mpp_init_partition: Calculate MPP domain decomposition 21 20 !! factorise : Calculate the factors of the no. of MPI processes … … 23 22 !!---------------------------------------------------------------------- 24 23 USE dom_oce ! ocean space and time domain 25 USE bdy_oce ! open BounDarY26 24 ! 27 25 USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges … … 37 35 38 36 INTEGER :: numbot = -1 ! 'bottom_level' local logical unit 39 INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit40 37 41 38 !!---------------------------------------------------------------------- … … 83 80 nbondi = 2 84 81 nbondj = 2 85 nidom = FLIO_DOM_NONE86 82 npolj = jperio 87 83 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) … … 99 95 CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', & 100 96 & 'the domain is lay out for distributed memory computing!' ) 97 98 #if defined key_agrif 99 IF (.not.agrif_root()) THEN 100 CALL agrif_nemo_init 101 ENDIF 102 103 IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) 104 print *,'nbcellsx = ',nbcellsx,nbghostcells_x 105 print *,'nbcellsy = ',nbcellsy,nbghostcells_y_s,nbghostcells_y_n 106 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 107 IF(lwp) THEN 108 WRITE(numout,*) 109 WRITE(numout,*) 'jpiglo should be: ', nbcellsx + 2 + 2*nbghostcells_x 110 ENDIF 111 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells_x' ) 112 ENDIF 113 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN 114 IF(lwp) THEN 115 WRITE(numout,*) 116 WRITE(numout,*) 'jpjglo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n 117 ENDIF 118 CALL ctl_stop( 'STOP', & 119 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' ) 120 ENDIF 121 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) 122 ENDIF 123 #endif 101 124 ! 102 125 END SUBROUTINE mpp_init … … 159 182 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilej, ildj, ioso, iowe ! - - 160 183 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 161 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 162 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & 163 & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & 164 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 165 & cn_ice, nn_ice_dta, & 166 & rn_ice_tem, rn_ice_sal, rn_ice_age, & 167 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 168 !!---------------------------------------------------------------------- 169 170 llwrtlay = lwp .OR. ln_ctl .OR. sn_cfctl%l_layout 171 ! do we need to take into account bdy_msk? 172 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist : BDY 173 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 174 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)', lwp ) 175 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist : BDY 176 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 177 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)', lwp ) 184 !!---------------------------------------------------------------------- 185 186 llwrtlay = lwp 178 187 ! 179 188 IF( ln_read_cfg ) CALL iom_open( cn_domcfg, numbot ) 180 IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy )181 189 ! 182 190 ! 1. Dimension arrays for subdomains … … 253 261 254 262 IF( numbot /= -1 ) CALL iom_close( numbot ) 255 IF( numbdy /= -1 ) CALL iom_close( numbdy )256 263 257 264 ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & … … 271 278 #if defined key_agrif 272 279 IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) 273 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells ) THEN 280 CALL agrif_nemo_init 281 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells_x ) THEN 274 282 IF(lwp) THEN 275 283 WRITE(numout,*) 276 WRITE(numout,*) 'jpiglo shou d be: ', nbcellsx + 2 + 2*nbghostcells284 WRITE(numout,*) 'jpiglo should be: ', nbcellsx + 2 + 2*nbghostcells_x 277 285 ENDIF 278 286 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' ) 279 287 ENDIF 280 IF( jpjglo /= nbcellsy + 2 + 2*nbghostcells) THEN288 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) THEN 281 289 IF(lwp) THEN 282 290 WRITE(numout,*) 283 WRITE(numout,*) 'jpjglo shoud be: ', nbcellsy + 2 + 2*nbghostcells291 WRITE(numout,*) 'jpjglo shoud be: ', nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n 284 292 ENDIF 285 CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nbghostcells' ) 293 CALL ctl_stop( 'STOP', & 294 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' ) 286 295 ENDIF 287 296 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) … … 639 648 ENDIF 640 649 ! 641 CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary)642 !643 650 IF( ln_nnogather ) THEN 644 651 CALL mpp_init_nfdcom ! northfold neighbour lists … … 875 882 876 883 ! if therr is no land and no print 877 IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1) THEN884 IF( .NOT. llist .AND. numbot == -1 ) THEN 878 885 ! get the smaller partition which gives the smallest subdomain size 879 886 ii = MINLOC(inbij1, mask = iszij1 == MINVAL(iszij1), dim = 1) … … 970 977 !!---------------------------------------------------------------------- 971 978 ! do nothing if there is no land-sea mask 972 IF( numbot == -1 .and. numbdy == -1) THEN979 IF( numbot == -1 ) THEN 973 980 propland = 0. 974 981 RETURN … … 1026 1033 !!---------------------------------------------------------------------- 1027 1034 ! do nothing if there is no land-sea mask 1028 IF( numbot == -1 .AND. numbdy == -1) THEN1035 IF( numbot == -1 ) THEN 1029 1036 ldisoce(:,:) = .TRUE. 1030 1037 RETURN … … 1081 1088 ! 1082 1089 INTEGER :: inumsave ! local logical unit 1083 REAL(wp), DIMENSION(jpiglo,kjcnt) :: zbot , zbdy1090 REAL(wp), DIMENSION(jpiglo,kjcnt) :: zbot 1084 1091 !!---------------------------------------------------------------------- 1085 1092 ! … … 1092 1099 ENDIF 1093 1100 1094 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists1095 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) )1096 zbot(:,:) = zbot(:,:) * zbdy(:,:)1097 ENDIF1098 1101 ! 1099 1102 ldoce(:,:) = zbot(:,:) > 0. … … 1101 1104 ! 1102 1105 END SUBROUTINE mpp_init_readbot_strip 1103 1104 1105 SUBROUTINE mpp_init_ioipsl1106 !!----------------------------------------------------------------------1107 !! *** ROUTINE mpp_init_ioipsl ***1108 !!1109 !! ** Purpose :1110 !!1111 !! ** Method :1112 !!1113 !! History :1114 !! 9.0 ! 04-03 (G. Madec ) MPP-IOIPSL1115 !! " " ! 08-12 (A. Coward) addition in case of jpni*jpnj < jpnij1116 !!----------------------------------------------------------------------1117 INTEGER, DIMENSION(2) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid1118 !!----------------------------------------------------------------------1119 1120 ! The domain is split only horizontally along i- or/and j- direction1121 ! So we need at the most only 1D arrays with 2 elements.1122 ! Set idompar values equivalent to the jpdom_local_noextra definition1123 ! used in IOM. This works even if jpnij .ne. jpni*jpnj.1124 iglo(1) = jpiglo1125 iglo(2) = jpjglo1126 iloc(1) = nlci1127 iloc(2) = nlcj1128 iabsf(1) = nimppt(narea)1129 iabsf(2) = njmppt(narea)1130 iabsl(:) = iabsf(:) + iloc(:) - 11131 ihals(1) = nldi - 11132 ihals(2) = nldj - 11133 ihale(1) = nlci - nlei1134 ihale(2) = nlcj - nlej1135 idid(1) = 11136 idid(2) = 21137 1138 IF(lwp) THEN1139 WRITE(numout,*)1140 WRITE(numout,*) 'mpp_init_ioipsl : iloc = ', iloc (1), iloc (2)1141 WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf(1), iabsf(2)1142 WRITE(numout,*) ' ihals = ', ihals(1), ihals(2)1143 WRITE(numout,*) ' ihale = ', ihale(1), ihale(2)1144 ENDIF1145 !1146 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)1147 !1148 END SUBROUTINE mpp_init_ioipsl1149 1150 1106 1151 1107 SUBROUTINE mpp_init_nfdcom -
utils/tools/DOMAINcfg/src/nemogcm.F90
r12414 r13204 56 56 USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 57 57 58 USE agrif_connect 59 USE agrif_dom_update 60 USE agrif_recompute_scales 61 58 62 IMPLICIT NONE 59 63 PRIVATE … … 64 68 65 69 CHARACTER(lc) :: cform_aaa="( /, 'AAAAAAAA', / ) " ! flag for output listing 66 67 #if defined key_agrif68 external agrif_boundary_connections, agrif_update_all, agrif_recompute_scalefactors69 #endif70 70 71 71 !!---------------------------------------------------------------------- … … 144 144 CHARACTER(len=120), DIMENSION(60) :: cltxt, cltxt2, clnam 145 145 !! 146 NAMELIST/namctl/ ln_ctl , sn_cfctl, nn_print, nn_ictls, nn_ictle, &147 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &148 & ln_timing, ln_diacfl149 146 NAMELIST/namcfg/ ln_e3_dep, & 150 147 & cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & … … 157 154 CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 158 155 CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 159 !160 REWIND( numnam_ref ) ! Namelist namctl in reference namelist161 READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )162 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )163 REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist164 READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )165 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )166 156 ! 167 157 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist … … 184 174 185 175 lwm = (narea == 1) ! control of output namelists 186 lwp = (narea == 1) .OR. ln_ctl! control of all listing output print176 lwp = (narea == 1) ! control of all listing output print 187 177 188 178 IF(lwm) THEN … … 190 180 ! file has been opened in call to mynode. nammpp has already been 191 181 ! written in mynode (if lk_mpp_mpi) 192 WRITE( numond, namctl )193 182 WRITE( numond, namcfg ) 194 183 ENDIF … … 258 247 ! !-------------------------------! 259 248 260 CALL nemo_ctl ! Control prints & Benchmark261 262 249 ! ! Domain decomposition 263 250 ! … … 269 256 END SUBROUTINE nemo_init 270 257 271 272 SUBROUTINE nemo_ctl273 !!----------------------------------------------------------------------274 !! *** ROUTINE nemo_ctl ***275 !!276 !! ** Purpose : control print setting277 !!278 !! ** Method : - print namctl information and check some consistencies279 !!----------------------------------------------------------------------280 !281 IF(lwp) THEN ! control print282 WRITE(numout,*)283 WRITE(numout,*) 'nemo_ctl: Control prints'284 WRITE(numout,*) '~~~~~~~~'285 WRITE(numout,*) ' Namelist namctl'286 WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl287 WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config288 WRITE(numout,*) ' sn_cfctl%l_runstat = ', sn_cfctl%l_runstat289 WRITE(numout,*) ' sn_cfctl%l_trcstat = ', sn_cfctl%l_trcstat290 WRITE(numout,*) ' sn_cfctl%l_oceout = ', sn_cfctl%l_oceout291 WRITE(numout,*) ' sn_cfctl%l_layout = ', sn_cfctl%l_layout292 WRITE(numout,*) ' sn_cfctl%l_mppout = ', sn_cfctl%l_mppout293 WRITE(numout,*) ' sn_cfctl%l_mpptop = ', sn_cfctl%l_mpptop294 WRITE(numout,*) ' sn_cfctl%procmin = ', sn_cfctl%procmin295 WRITE(numout,*) ' sn_cfctl%procmax = ', sn_cfctl%procmax296 WRITE(numout,*) ' sn_cfctl%procincr = ', sn_cfctl%procincr297 WRITE(numout,*) ' sn_cfctl%ptimincr = ', sn_cfctl%ptimincr298 WRITE(numout,*) ' level of print nn_print = ', nn_print299 WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls300 WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle301 WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls302 WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle303 WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt304 WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt305 WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing306 WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl307 ENDIF308 !309 nprint = nn_print ! convert DOCTOR namelist names into OLD names310 nictls = nn_ictls311 nictle = nn_ictle312 njctls = nn_jctls313 njctle = nn_jctle314 isplt = nn_isplt315 jsplt = nn_jsplt316 317 !318 ! ! Parameter control319 !320 IF( ln_ctl ) THEN ! sub-domain area indices for the control prints321 IF( lk_mpp .AND. jpnij > 1 ) THEN322 isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain323 ELSE324 IF( isplt == 1 .AND. jsplt == 1 ) THEN325 CALL ctl_warn( ' - isplt & jsplt are equal to 1', &326 & ' - the print control will be done over the whole domain' )327 ENDIF328 ijsplt = isplt * jsplt ! total number of processors ijsplt329 ENDIF330 IF(lwp) WRITE(numout,*)' - The total number of processors over which the'331 IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt332 !333 ! ! indices used for the SUM control334 IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area335 lsp_area = .FALSE.336 ELSE ! print control done over a specific area337 lsp_area = .TRUE.338 IF( nictls < 1 .OR. nictls > jpiglo ) THEN339 CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )340 nictls = 1341 ENDIF342 IF( nictle < 1 .OR. nictle > jpiglo ) THEN343 CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )344 nictle = jpiglo345 ENDIF346 IF( njctls < 1 .OR. njctls > jpjglo ) THEN347 CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )348 njctls = 1349 ENDIF350 IF( njctle < 1 .OR. njctle > jpjglo ) THEN351 CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )352 njctle = jpjglo353 ENDIF354 ENDIF355 ENDIF356 !357 ! IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', &358 ! & 'Compile with key_nosignedzero enabled:', &359 ! & '--> add -Dkey_nosignedzero to the definition of %CPP in your arch file' )360 !361 #if defined key_agrif362 IF( ln_timing ) CALL ctl_stop( 'AGRIF not implemented with ln_timing = true')363 #endif364 !365 END SUBROUTINE nemo_ctl366 367 368 258 SUBROUTINE nemo_closefile 369 259 !!---------------------------------------------------------------------- … … 381 271 IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist 382 272 IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist 383 IF( numnam_ice_ref /= -1 ) CLOSE( numnam_ice_ref ) ! ice reference namelist384 IF( numnam_ice_cfg /= -1 ) CLOSE( numnam_ice_cfg ) ! ice configuration namelist385 IF( lwm.AND.numoni /= -1 ) CLOSE( numoni ) ! ice output namelist386 IF( numevo_ice /= -1 ) CLOSE( numevo_ice ) ! ice variables (temp. evolution)387 273 IF( numout /= 6 ) CLOSE( numout ) ! standard model output file 388 IF( numdct_vol /= -1 ) CLOSE( numdct_vol ) ! volume transports389 IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports390 IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports391 274 ! 392 275 numout = 6 ! redefine numout in case it is used after this point... … … 408 291 !!---------------------------------------------------------------------- 409 292 ! 410 ierr = dom_oce_alloc () ! ocean domain 293 ierr = 0 294 ierr = ierr + dom_oce_alloc () ! ocean domain 411 295 ! 412 296 CALL mpp_sum( 'nemogcm', ierr ) … … 416 300 417 301 302 SUBROUTINE nemo_partition( num_pes ) 303 !!---------------------------------------------------------------------- 304 !! *** ROUTINE nemo_partition *** 305 !! 306 !! ** Purpose : 307 !! 308 !! ** Method : 309 !!---------------------------------------------------------------------- 310 INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have 311 ! 312 INTEGER, PARAMETER :: nfactmax = 20 313 INTEGER :: nfact ! The no. of factors returned 314 INTEGER :: ierr ! Error flag 315 INTEGER :: ji 316 INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value 317 INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors 318 !!---------------------------------------------------------------------- 319 ! 320 ierr = 0 321 ! 322 CALL factorise( ifact, nfactmax, nfact, num_pes, ierr ) 323 ! 324 IF( nfact <= 1 ) THEN 325 WRITE (numout, *) 'WARNING: factorisation of number of PEs failed' 326 WRITE (numout, *) ' : using grid of ',num_pes,' x 1' 327 jpnj = 1 328 jpni = num_pes 329 ELSE 330 ! Search through factors for the pair that are closest in value 331 mindiff = 1000000 332 imin = 1 333 DO ji = 1, nfact-1, 2 334 idiff = ABS( ifact(ji) - ifact(ji+1) ) 335 IF( idiff < mindiff ) THEN 336 mindiff = idiff 337 imin = ji 338 ENDIF 339 END DO 340 jpnj = ifact(imin) 341 jpni = ifact(imin + 1) 342 ENDIF 343 ! 344 jpnij = jpni*jpnj 345 ! 346 END SUBROUTINE nemo_partition 347 348 349 SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr ) 350 !!---------------------------------------------------------------------- 351 !! *** ROUTINE factorise *** 352 !! 353 !! ** Purpose : return the prime factors of n. 354 !! knfax factors are returned in array kfax which is of 355 !! maximum dimension kmaxfax. 356 !! ** Method : 357 !!---------------------------------------------------------------------- 358 INTEGER , INTENT(in ) :: kn, kmaxfax 359 INTEGER , INTENT( out) :: kerr, knfax 360 INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax 361 ! 362 INTEGER :: ifac, jl, inu 363 INTEGER, PARAMETER :: ntest = 14 364 INTEGER, DIMENSION(ntest) :: ilfax 365 !!---------------------------------------------------------------------- 366 ! 367 ! lfax contains the set of allowed factors. 368 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 369 ! 370 ! Clear the error flag and initialise output vars 371 kerr = 0 372 kfax = 1 373 knfax = 0 374 ! 375 ! Find the factors of n. 376 IF( kn == 1 ) GOTO 20 377 378 ! nu holds the unfactorised part of the number. 379 ! knfax holds the number of factors found. 380 ! l points to the allowed factor list. 381 ! ifac holds the current factor. 382 ! 383 inu = kn 384 knfax = 0 385 ! 386 DO jl = ntest, 1, -1 387 ! 388 ifac = ilfax(jl) 389 IF( ifac > inu ) CYCLE 390 391 ! Test whether the factor will divide. 392 393 IF( MOD(inu,ifac) == 0 ) THEN 394 ! 395 knfax = knfax + 1 ! Add the factor to the list 396 IF( knfax > kmaxfax ) THEN 397 kerr = 6 398 write (*,*) 'FACTOR: insufficient space in factor array ', knfax 399 return 400 ENDIF 401 kfax(knfax) = ifac 402 ! Store the other factor that goes with this one 403 knfax = knfax + 1 404 kfax(knfax) = inu / ifac 405 !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax) 406 ENDIF 407 ! 408 END DO 409 ! 410 20 CONTINUE ! Label 20 is the exit point from the factor search loop. 411 ! 412 END SUBROUTINE factorise 413 414 415 SUBROUTINE nemo_northcomms 416 !!---------------------------------------------------------------------- 417 !! *** ROUTINE nemo_northcomms *** 418 !! ** Purpose : Setup for north fold exchanges with explicit 419 !! point-to-point messaging 420 !! 421 !! ** Method : Initialization of the northern neighbours lists. 422 !!---------------------------------------------------------------------- 423 !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) 424 !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) 425 !!---------------------------------------------------------------------- 426 INTEGER :: sxM, dxM, sxT, dxT, jn 427 INTEGER :: njmppmax 428 !!---------------------------------------------------------------------- 429 ! 430 njmppmax = MAXVAL( njmppt ) 431 ! 432 !initializes the north-fold communication variables 433 isendto(:) = 0 434 nsndto = 0 435 ! 436 !if I am a process in the north 437 IF ( njmpp == njmppmax ) THEN 438 !sxM is the first point (in the global domain) needed to compute the 439 !north-fold for the current process 440 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1 441 !dxM is the last point (in the global domain) needed to compute the 442 !north-fold for the current process 443 dxM = jpiglo - nimppt(narea) + 2 444 445 !loop over the other north-fold processes to find the processes 446 !managing the points belonging to the sxT-dxT range 447 448 DO jn = 1, jpni 449 !sxT is the first point (in the global domain) of the jn 450 !process 451 sxT = nfiimpp(jn, jpnj) 452 !dxT is the last point (in the global domain) of the jn 453 !process 454 dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 455 IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN 456 nsndto = nsndto + 1 457 isendto(nsndto) = jn 458 ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN 459 nsndto = nsndto + 1 460 isendto(nsndto) = jn 461 ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN 462 nsndto = nsndto + 1 463 isendto(nsndto) = jn 464 END IF 465 END DO 466 nfsloop = 1 467 nfeloop = nlci 468 DO jn = 2,jpni-1 469 IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN 470 IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN 471 nfsloop = nldi 472 ENDIF 473 IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN 474 nfeloop = nlei 475 ENDIF 476 ENDIF 477 END DO 478 479 ENDIF 480 #if defined key_mpp_mpi 481 l_north_nogather = .TRUE. 482 #endif 483 END SUBROUTINE nemo_northcomms 484 418 485 419 486 !!====================================================================== -
utils/tools/DOMAINcfg/src/par_oce.f90
r12414 r13204 13 13 PUBLIC 14 14 15 INTEGER , PUBLIC :: nn_dttrc !: frequency of step on passive tracers 15 16 CHARACTER(lc) :: cp_cfg !: name of the configuration 16 17 CHARACTER(lc) :: cp_cfz !: name of the zoom of configuration … … 54 55 ! global domain size for AGRIF !!! * total AGRIF computational domain * 55 56 INTEGER, PUBLIC :: nbug_in_agrif_conv_do_not_remove_or_modify = 1 - 1 56 INTEGER, PUBLIC, PARAMETER :: nbghostcells = 3 !: number of ghost cells 57 INTEGER, PUBLIC :: nbcellsx ! = jpiglo - 2 - 2*nbghostcells !: number of cells in i-direction 58 INTEGER, PUBLIC :: nbcellsy ! = jpjglo - 2 - 2*nbghostcells !: number of cells in j-direction 57 INTEGER, PUBLIC, PARAMETER :: nbghostcells = 3 !: number of ghost cells: default value 58 INTEGER, PUBLIC :: nbghostcells_x !: number of ghost cells in i-direction 59 INTEGER, PUBLIC :: nbghostcells_y_s !: number of ghost cells in j-direction at south 60 INTEGER, PUBLIC :: nbghostcells_y_n !: number of ghost cells in j-direction at north 61 INTEGER, PUBLIC :: nbcellsx ! = jpiglo - 2 - 2*nbghostcells_x !: number of cells in i-direction 62 INTEGER, PUBLIC :: nbcellsy ! = jpjglo - 2 - 2*nbghostcells_y !: number of cells in j-direction 59 63 60 64 ! local domain size !!! * local computational domain * -
utils/tools/DOMAINcfg/src/phycst.F90
r12414 r13204 37 37 REAL(wp), PUBLIC :: ra = 6371229._wp !: earth radius [m] 38 38 REAL(wp), PUBLIC :: grav = 9.80665_wp !: gravity [m/s2] 39 REAL(wp), PUBLIC :: rt0 = 273.15_wp !: freezing point of fresh water [Kelvin]40 39 41 REAL(wp), PUBLIC :: rau0 !: volumic mass of reference [kg/m3]42 REAL(wp), PUBLIC :: r1_rau0 !: = 1. / rau0 [m3/kg]43 REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin]44 REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J]45 REAL(wp), PUBLIC :: rau0_rcp !: = rau0 * rcp46 REAL(wp), PUBLIC :: r1_rau0_rcp !: = 1. / ( rau0 * rcp )47 48 REAL(wp), PUBLIC :: emic = 0.97_wp !: emissivity of snow or ice (not used?)49 50 REAL(wp), PUBLIC :: sice = 6.0_wp !: salinity of ice (for pisces) [psu]51 REAL(wp), PUBLIC :: soce = 34.7_wp !: salinity of sea (for pisces and isf) [psu]52 REAL(wp), PUBLIC :: rLevap = 2.5e+6_wp !: latent heat of evaporation (water)53 REAL(wp), PUBLIC :: vkarmn = 0.4_wp !: von Karman constant54 REAL(wp), PUBLIC :: stefan = 5.67e-8_wp !: Stefan-Boltzmann constant55 56 REAL(wp), PUBLIC :: rhos = 330._wp !: volumic mass of snow [kg/m3]57 REAL(wp), PUBLIC :: rhoi = 917._wp !: volumic mass of sea ice [kg/m3]58 REAL(wp), PUBLIC :: rhow = 1000._wp !: volumic mass of freshwater in melt ponds [kg/m3]59 REAL(wp), PUBLIC :: rcnd_i = 2.034396_wp !: thermal conductivity of fresh ice [W/m/K]60 REAL(wp), PUBLIC :: rcpi = 2067.0_wp !: specific heat of fresh ice [J/kg/K]61 REAL(wp), PUBLIC :: rLsub = 2.834e+6_wp !: pure ice latent heat of sublimation [J/kg]62 REAL(wp), PUBLIC :: rLfus = 0.334e+6_wp !: latent heat of fusion of fresh ice [J/kg]63 REAL(wp), PUBLIC :: rTmlt = 0.054_wp !: decrease of seawater meltpoint with salinity64 65 REAL(wp), PUBLIC :: r1_rhoi !: 1 / rhoi66 REAL(wp), PUBLIC :: r1_rhos !: 1 / rhos67 REAL(wp), PUBLIC :: r1_rcpi !: 1 / rcpi68 40 !!---------------------------------------------------------------------- 69 41 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 89 61 #endif 90 62 91 r1_rhoi = 1._wp / rhoi92 r1_rhos = 1._wp / rhos93 r1_rcpi = 1._wp / rcpi94 95 IF(lwp) THEN96 WRITE(numout,*)97 WRITE(numout,*) 'phy_cst : initialization of ocean parameters and constants'98 WRITE(numout,*) '~~~~~~~'99 WRITE(numout,*) ' mathematical constant rpi = ', rpi100 WRITE(numout,*) ' day rday = ', rday, ' s'101 WRITE(numout,*) ' sideral year rsiyea = ', rsiyea, ' s'102 WRITE(numout,*) ' sideral day rsiday = ', rsiday, ' s'103 WRITE(numout,*) ' omega omega = ', omega, ' s^-1'104 WRITE(numout,*)105 WRITE(numout,*) ' nb of months per year raamo = ', raamo, ' months'106 WRITE(numout,*) ' nb of hours per day rjjhh = ', rjjhh, ' hours'107 WRITE(numout,*) ' nb of minutes per hour rhhmm = ', rhhmm, ' mn'108 WRITE(numout,*) ' nb of seconds per minute rmmss = ', rmmss, ' s'109 WRITE(numout,*)110 WRITE(numout,*) ' earth radius ra = ', ra , ' m'111 WRITE(numout,*) ' gravity grav = ', grav , ' m/s^2'112 WRITE(numout,*)113 WRITE(numout,*) ' freezing point of water rt0 = ', rt0 , ' K'114 WRITE(numout,*)115 WRITE(numout,*) ' reference density and heat capacity now defined in eosbn2.f90'116 WRITE(numout,*)117 WRITE(numout,*) ' thermal conductivity of pure ice = ', rcnd_i , ' J/s/m/K'118 WRITE(numout,*) ' thermal conductivity of snow is defined in a namelist '119 WRITE(numout,*) ' fresh ice specific heat = ', rcpi , ' J/kg/K'120 WRITE(numout,*) ' latent heat of fusion of fresh ice / snow = ', rLfus , ' J/kg'121 WRITE(numout,*) ' latent heat of subl. of fresh ice / snow = ', rLsub , ' J/kg'122 WRITE(numout,*) ' density of sea ice = ', rhoi , ' kg/m^3'123 WRITE(numout,*) ' density of snow = ', rhos , ' kg/m^3'124 WRITE(numout,*) ' density of freshwater (in melt ponds) = ', rhow , ' kg/m^3'125 WRITE(numout,*) ' salinity of ice (for pisces) = ', sice , ' psu'126 WRITE(numout,*) ' salinity of sea (for pisces and isf) = ', soce , ' psu'127 WRITE(numout,*) ' latent heat of evaporation (water) = ', rLevap , ' J/m^3'128 WRITE(numout,*) ' von Karman constant = ', vkarmn129 WRITE(numout,*) ' Stefan-Boltzmann constant = ', stefan , ' J/s/m^2/K^4'130 WRITE(numout,*)131 WRITE(numout,*) ' conversion: degre ==> radian rad = ', rad132 WRITE(numout,*)133 WRITE(numout,*) ' smallest real computer value rsmall = ', rsmall134 ENDIF135 136 63 END SUBROUTINE phy_cst 137 64
Note: See TracChangeset
for help on using the changeset viewer.