Changeset 10727 for utils/tools_AGRIF_CMEMS_2020/DOMAINcfg/src/domwri.F90
- Timestamp:
- 2019-02-27T17:02:02+01:00 (5 years ago)
- File:
-
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
utils/tools_AGRIF_CMEMS_2020/DOMAINcfg/src/domwri.F90
r10725 r10727 8 8 !! NEMO 1.0 ! 2002-08 (G. Madec) F90 and several file 9 9 !! 3.0 ! 2008-01 (S. Masson) add dom_uniq 10 !! 4.0 ! 2016-01 (G. Madec) simplified mesh_mask.nc file 10 11 !!---------------------------------------------------------------------- 11 12 … … 16 17 !!---------------------------------------------------------------------- 17 18 USE dom_oce ! ocean space and time domain 19 USE phycst , ONLY : rsmall 20 ! USE wet_dry, ONLY : ll_wd ! Wetting and drying 21 ! 18 22 USE in_out_manager ! I/O manager 19 23 USE iom ! I/O library 20 24 USE lbclnk ! lateral boundary conditions - mpp exchanges 21 25 USE lib_mpp ! MPP library 22 USE wrk_nemo ! Memory allocation23 USE timing ! Timing24 USE phycst25 26 26 27 IMPLICIT NONE … … 28 29 29 30 PUBLIC dom_wri ! routine called by inidom.F90 30 PUBLIC dom_wri_coordinate ! routine called by domhgr.F9031 31 PUBLIC dom_stiff ! routine called by inidom.F90 32 32 33 !!---------------------------------------------------------------------- 34 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 35 !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $ 36 !! Software governed by the CeCILL licence (./LICENSE) 33 !! * Substitutions 34 # include "vectopt_loop_substitute.h90" 35 !!---------------------------------------------------------------------- 36 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 37 !! $Id: domwri.F90 10425 2018-12-19 21:54:16Z smasson $ 38 !! Software governed by the CeCILL license (see ./LICENSE) 37 39 !!---------------------------------------------------------------------- 38 40 CONTAINS 39 40 SUBROUTINE dom_wri_coordinate41 !!----------------------------------------------------------------------42 !! *** ROUTINE dom_wri_coordinate ***43 !!44 !! ** Purpose : Create the NetCDF file which contains all the45 !! standard coordinate information plus the surface,46 !! e1e2u and e1e2v. By doing so, those surface will47 !! not be changed by the reduction of e1u or e2v scale48 !! factors in some straits.49 !! NB: call just after the read of standard coordinate50 !! and the reduction of scale factors in some straits51 !!52 !! ** output file : coordinate_e1e2u_v.nc53 !!----------------------------------------------------------------------54 INTEGER :: inum0 ! temprary units for 'coordinate_e1e2u_v.nc' file55 CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations)56 ! ! workspaces57 REAL(wp), POINTER, DIMENSION(:,: ) :: zprt, zprw58 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv59 !!----------------------------------------------------------------------60 !61 IF( nn_timing == 1 ) CALL timing_start('dom_wri_coordinate')62 !63 IF(lwp) WRITE(numout,*)64 IF(lwp) WRITE(numout,*) 'dom_wri_coordinate : create NetCDF coordinate file'65 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~'66 67 clnam0 = 'coordinate_e1e2u_v' ! filename (mesh and mask informations)68 69 ! create 'coordinate_e1e2u_v.nc' file70 ! ============================71 !72 CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib )73 !74 ! ! horizontal mesh (inum3)75 CALL iom_rstput( 0, 0, inum0, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude76 CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r8 )77 CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r8 )78 CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r8 )79 80 CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude81 CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r8 )82 CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r8 )83 CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r8 )84 85 CALL iom_rstput( 0, 0, inum0, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors86 CALL iom_rstput( 0, 0, inum0, 'e1u', e1u, ktype = jp_r8 )87 CALL iom_rstput( 0, 0, inum0, 'e1v', e1v, ktype = jp_r8 )88 CALL iom_rstput( 0, 0, inum0, 'e1f', e1f, ktype = jp_r8 )89 90 CALL iom_rstput( 0, 0, inum0, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors91 CALL iom_rstput( 0, 0, inum0, 'e2u', e2u, ktype = jp_r8 )92 CALL iom_rstput( 0, 0, inum0, 'e2v', e2v, ktype = jp_r8 )93 CALL iom_rstput( 0, 0, inum0, 'e2f', e2f, ktype = jp_r8 )94 95 CALL iom_rstput( 0, 0, inum0, 'e1e2u', e1e2u, ktype = jp_r8 )96 CALL iom_rstput( 0, 0, inum0, 'e1e2v', e1e2v, ktype = jp_r8 )97 98 CALL iom_close( inum0 )99 !100 IF( nn_timing == 1 ) CALL timing_stop('dom_wri_coordinate')101 !102 END SUBROUTINE dom_wri_coordinate103 104 41 105 42 SUBROUTINE dom_wri … … 112 49 !! diagnostic computation. 113 50 !! 114 !! ** Method : Write in a file all the arrays generated in routines 115 !! domhgr, domzgr, and dommsk. Note: the file contain depends on 116 !! the vertical coord. used (z-coord, partial steps, s-coord) 117 !! MOD(nmsh, 3) = 1 : 'mesh_mask.nc' file 118 !! = 2 : 'mesh.nc' and mask.nc' files 119 !! = 0 : 'mesh_hgr.nc', 'mesh_zgr.nc' and 120 !! 'mask.nc' files 121 !! For huge size domain, use option 2 or 3 depending on your 122 !! vertical coordinate. 123 !! 124 !! if nmsh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw] 125 !! if 3 < nmsh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays 126 !! corresponding to the depth of the bottom t- and w-points 127 !! if 6 < nmsh <= 9: write 2D arrays corresponding to the depth and the 128 !! thickness (e3[tw]_ps) of the bottom points 51 !! ** Method : create a file with all domain related arrays 129 52 !! 130 53 !! ** output file : meshmask.nc : domain size, horizontal grid-point position, 131 54 !! masks, depth and vertical scale factors 132 55 !!---------------------------------------------------------------------- 133 !! 134 INTEGER :: inum0 ! temprary units for 'mesh_mask.nc' file 135 INTEGER :: inum1 ! temprary units for 'mesh.nc' file 136 INTEGER :: inum2 ! temprary units for 'mask.nc' file 137 INTEGER :: inum3 ! temprary units for 'mesh_hgr.nc' file 138 INTEGER :: inum4 ! temprary units for 'mesh_zgr.nc' file 139 CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations) 140 CHARACTER(len=21) :: clnam1 ! filename (mesh informations) 141 CHARACTER(len=21) :: clnam2 ! filename (mask informations) 142 CHARACTER(len=21) :: clnam3 ! filename (horizontal mesh informations) 143 CHARACTER(len=21) :: clnam4 ! filename (vertical mesh informations) 56 INTEGER :: inum ! temprary units for 'mesh_mask.nc' file 57 CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) 144 58 INTEGER :: ji, jj, jk ! dummy loop indices 145 ! ! workspaces 146 REAL(wp), POINTER, DIMENSION(:,: ) :: zprt, zprw 147 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv 148 !!---------------------------------------------------------------------- 149 ! 150 IF( nn_timing == 1 ) CALL timing_start('dom_wri') 151 ! 152 CALL wrk_alloc( jpi, jpj, zprt, zprw ) 153 CALL wrk_alloc( jpi, jpj, jpk, zdepu, zdepv ) 59 INTEGER :: izco, izps, isco, icav 60 ! 61 REAL(wp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace 62 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace 63 !!---------------------------------------------------------------------- 154 64 ! 155 65 IF(lwp) WRITE(numout,*) … … 157 67 IF(lwp) WRITE(numout,*) '~~~~~~~' 158 68 159 clnam0 = 'mesh_mask' ! filename (mesh and mask informations) 160 clnam1 = 'mesh' ! filename (mesh informations) 161 clnam2 = 'mask' ! filename (mask informations) 162 clnam3 = 'mesh_hgr' ! filename (horizontal mesh informations) 163 clnam4 = 'mesh_zgr' ! filename (vertical mesh informations) 164 165 SELECT CASE ( MOD(nmsh, 3) ) 166 ! ! ============================ 167 CASE ( 1 ) ! create 'mesh_mask.nc' file 168 ! ! ============================ 169 CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib ) 170 inum2 = inum0 ! put all the informations 171 inum3 = inum0 ! in unit inum0 172 inum4 = inum0 173 174 ! ! ============================ 175 CASE ( 2 ) ! create 'mesh.nc' and 176 ! ! 'mask.nc' files 177 ! ! ============================ 178 CALL iom_open( TRIM(clnam1), inum1, ldwrt = .TRUE., kiolib = jprstlib ) 179 CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib ) 180 inum3 = inum1 ! put mesh informations 181 inum4 = inum1 ! in unit inum1 182 ! ! ============================ 183 CASE ( 0 ) ! create 'mesh_hgr.nc' 184 ! ! 'mesh_zgr.nc' and 185 ! ! 'mask.nc' files 186 ! ! ============================ 187 CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib ) 188 CALL iom_open( TRIM(clnam3), inum3, ldwrt = .TRUE., kiolib = jprstlib ) 189 CALL iom_open( TRIM(clnam4), inum4, ldwrt = .TRUE., kiolib = jprstlib ) 190 ! 191 END SELECT 192 193 ! ! masks (inum2) 194 CALL iom_rstput( 0, 0, inum2, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask 195 CALL iom_rstput( 0, 0, inum2, 'umask', umask, ktype = jp_i1 ) 196 CALL iom_rstput( 0, 0, inum2, 'vmask', vmask, ktype = jp_i1 ) 197 CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 ) 69 clnam = 'mesh_mask' ! filename (mesh and mask informations) 70 71 ! ! ============================ 72 ! ! create 'mesh_mask.nc' file 73 ! ! ============================ 74 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 75 ! 76 ! ! global domain size 77 CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 ) 78 CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 ) 79 CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 ) 80 81 ! ! domain characteristics 82 CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) 83 ! ! type of vertical coordinate 84 IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF 85 IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF 86 IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF 87 CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 ) 88 CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 ) 89 CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 ) 90 ! ! ocean cavities under iceshelves 91 IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF 92 CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) 93 94 ! ! masks 95 CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask 96 CALL iom_rstput( 0, 0, inum, 'umask', umask, ktype = jp_i1 ) 97 CALL iom_rstput( 0, 0, inum, 'vmask', vmask, ktype = jp_i1 ) 98 CALL iom_rstput( 0, 0, inum, 'fmask', fmask, ktype = jp_i1 ) 198 99 199 100 CALL dom_uniq( zprw, 'T' ) 200 101 DO jj = 1, jpj 201 102 DO ji = 1, jpi 202 jk=mikt(ji,jj) 203 zprt(ji,jj) = tmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 103 zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 204 104 END DO 205 105 END DO ! ! unique point mask 206 CALL iom_rstput( 0, 0, inum 2, 'tmaskutil', zprt, ktype = jp_i1 )106 CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) 207 107 CALL dom_uniq( zprw, 'U' ) 208 108 DO jj = 1, jpj 209 109 DO ji = 1, jpi 210 jk=miku(ji,jj) 211 zprt(ji,jj) = umask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 110 zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj) ! ! unique point mask 212 111 END DO 213 112 END DO 214 CALL iom_rstput( 0, 0, inum 2, 'umaskutil', zprt, ktype = jp_i1 )113 CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) 215 114 CALL dom_uniq( zprw, 'V' ) 216 115 DO jj = 1, jpj 217 116 DO ji = 1, jpi 218 jk=mikv(ji,jj) 219 zprt(ji,jj) = vmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 117 zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 220 118 END DO 221 119 END DO 222 CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 ) 223 CALL dom_uniq( zprw, 'F' ) 224 DO jj = 1, jpj 225 DO ji = 1, jpi 226 jk=mikf(ji,jj) 227 zprt(ji,jj) = fmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 228 END DO 229 END DO 230 CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 ) 120 CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) 121 !!gm ssfmask has been removed ==>> find another solution to defined fmaskutil 122 !! Here we just remove the output of fmaskutil. 123 ! CALL dom_uniq( zprw, 'F' ) 124 ! DO jj = 1, jpj 125 ! DO ji = 1, jpi 126 ! zprt(ji,jj) = ssfmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 127 ! END DO 128 ! END DO 129 ! CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) 130 !!gm 231 131 232 132 ! ! horizontal mesh (inum3) 233 CALL iom_rstput( 0, 0, inum 3, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude234 CALL iom_rstput( 0, 0, inum 3, 'glamu', glamu, ktype = jp_r8 )235 CALL iom_rstput( 0, 0, inum 3, 'glamv', glamv, ktype = jp_r8 )236 CALL iom_rstput( 0, 0, inum 3, 'glamf', glamf, ktype = jp_r8 )237 238 CALL iom_rstput( 0, 0, inum 3, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude239 CALL iom_rstput( 0, 0, inum 3, 'gphiu', gphiu, ktype = jp_r8 )240 CALL iom_rstput( 0, 0, inum 3, 'gphiv', gphiv, ktype = jp_r8 )241 CALL iom_rstput( 0, 0, inum 3, 'gphif', gphif, ktype = jp_r8 )242 243 CALL iom_rstput( 0, 0, inum 3, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors244 CALL iom_rstput( 0, 0, inum 3, 'e1u', e1u, ktype = jp_r8 )245 CALL iom_rstput( 0, 0, inum 3, 'e1v', e1v, ktype = jp_r8 )246 CALL iom_rstput( 0, 0, inum 3, 'e1f', e1f, ktype = jp_r8 )247 248 CALL iom_rstput( 0, 0, inum 3, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors249 CALL iom_rstput( 0, 0, inum 3, 'e2u', e2u, ktype = jp_r8 )250 CALL iom_rstput( 0, 0, inum 3, 'e2v', e2v, ktype = jp_r8 )251 CALL iom_rstput( 0, 0, inum 3, 'e2f', e2f, ktype = jp_r8 )252 253 CALL iom_rstput( 0, 0, inum 3, 'ff_f', ff_f, ktype = jp_r8 )! ! coriolis factor254 CALL iom_rstput( 0, 0, inum 3, 'ff_t', ff_t, ktype = jp_r8 ) ! ! coriolis factor133 CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude 134 CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 ) 135 CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) 136 CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) 137 138 CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude 139 CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) 140 CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) 141 CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) 142 143 CALL iom_rstput( 0, 0, inum, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors 144 CALL iom_rstput( 0, 0, inum, 'e1u', e1u, ktype = jp_r8 ) 145 CALL iom_rstput( 0, 0, inum, 'e1v', e1v, ktype = jp_r8 ) 146 CALL iom_rstput( 0, 0, inum, 'e1f', e1f, ktype = jp_r8 ) 147 148 CALL iom_rstput( 0, 0, inum, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors 149 CALL iom_rstput( 0, 0, inum, 'e2u', e2u, ktype = jp_r8 ) 150 CALL iom_rstput( 0, 0, inum, 'e2v', e2v, ktype = jp_r8 ) 151 CALL iom_rstput( 0, 0, inum, 'e2f', e2f, ktype = jp_r8 ) 152 153 CALL iom_rstput( 0, 0, inum, 'ff_f', ff_f, ktype = jp_r8 ) ! ! coriolis factor 154 CALL iom_rstput( 0, 0, inum, 'ff_t', ff_t, ktype = jp_r8 ) 255 155 256 156 ! note that mbkt is set to 1 over land ==> use surface tmask 257 157 zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp ) 258 CALL iom_rstput( 0, 0, inum 4, 'mbathy', zprt, ktype = jp_i2) ! ! nb of ocean T-points158 CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points 259 159 zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp ) 260 CALL iom_rstput( 0, 0, inum 4, 'misf', zprt, ktype = jp_i2) ! ! nb of ocean T-points160 CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points 261 161 zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp ) 262 CALL iom_rstput( 0, 0, inum4, 'isfdraft', zprt, ktype = jp_r8 ) ! ! nb of ocean T-points 263 264 IF( ln_sco ) THEN ! s-coordinate 265 CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt ) 266 CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu ) 267 CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv ) 268 CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf ) 269 ! 270 CALL iom_rstput( 0, 0, inum4, 'gsigt', gsigt ) ! ! scaling coef. 271 CALL iom_rstput( 0, 0, inum4, 'gsigw', gsigw ) 272 CALL iom_rstput( 0, 0, inum4, 'gsi3w', gsi3w ) 273 CALL iom_rstput( 0, 0, inum4, 'esigt', esigt ) 274 CALL iom_rstput( 0, 0, inum4, 'esigw', esigw ) 275 ! 276 CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) ! ! scale factors 277 CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 278 CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 279 CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 280 ! 281 CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d ) ! ! stretched system 282 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 283 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 ) 284 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) 162 CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 ) ! ! nb of ocean T-points 163 ! ! vertical mesh 164 CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8 ) ! ! scale factors 165 CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8 ) 166 CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8 ) 167 CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8 ) 168 ! 169 CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system 170 CALL iom_rstput( 0, 0, inum, 'gdepw_1d' , gdepw_1d , ktype = jp_r8 ) 171 CALL iom_rstput( 0, 0, inum, 'gdept_0' , gdept_0 , ktype = jp_r8 ) 172 CALL iom_rstput( 0, 0, inum, 'gdepw_0' , gdepw_0 , ktype = jp_r8 ) 173 ! 174 IF( ln_sco ) THEN ! s-coordinate stiffness 285 175 CALL dom_stiff( zprt ) 286 CALL iom_rstput( 0, 0, inum 4, 'stiffness', zprt ) !! Max. grid stiffness ratio176 CALL iom_rstput( 0, 0, inum, 'stiffness', zprt ) ! Max. grid stiffness ratio 287 177 ENDIF 288 289 IF( ln_zps ) THEN ! z-coordinate - partial steps 290 ! 291 IF( nmsh <= 6 ) THEN ! ! 3D vertical scale factors 292 CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) 293 CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 294 CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 295 CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 296 ELSE ! ! 2D masked bottom ocean scale factors 297 DO jj = 1,jpj 298 DO ji = 1,jpi 299 e3tp(ji,jj) = e3t_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj) 300 e3wp(ji,jj) = e3w_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj) 301 END DO 302 END DO 303 CALL iom_rstput( 0, 0, inum4, 'e3t_ps', e3tp ) 304 CALL iom_rstput( 0, 0, inum4, 'e3w_ps', e3wp ) 305 END IF 306 ! 307 IF( nmsh <= 3 ) THEN ! ! 3D depth 308 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 ) 309 DO jk = 1,jpk 310 DO jj = 1, jpjm1 311 DO ji = 1, jpim1 ! vector opt. 312 zdepu(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj ,jk) ) 313 zdepv(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji ,jj+1,jk) ) 314 END DO 315 END DO 316 END DO 317 CALL lbc_lnk( zdepu, 'U', 1. ) ; CALL lbc_lnk( zdepv, 'V', 1. ) 318 CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r8 ) 319 CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r8 ) 320 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) 321 ELSE ! ! 2D bottom depth 322 DO jj = 1,jpj 323 DO ji = 1,jpi 324 zprt(ji,jj) = gdept_0(ji,jj,mbkt(ji,jj) ) * ssmask(ji,jj) 325 zprw(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) * ssmask(ji,jj) 326 END DO 327 END DO 328 CALL iom_rstput( 0, 0, inum4, 'hdept', zprt, ktype = jp_r8 ) 329 CALL iom_rstput( 0, 0, inum4, 'hdepw', zprw, ktype = jp_r8 ) 330 ENDIF 331 ! 332 CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! reference z-coord. 333 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 334 CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) 335 CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) 336 ENDIF 337 338 IF( ln_zco ) THEN 339 ! ! z-coordinate - full steps 340 CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! depth 341 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 342 CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) ! ! scale factors 343 CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) 344 ENDIF 178 ! 179 ! IF( ll_wd ) CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) 180 345 181 ! ! ============================ 346 !! close the files182 CALL iom_close( inum ) ! close the files 347 183 ! ! ============================ 348 SELECT CASE ( MOD(nmsh, 3) )349 CASE ( 1 )350 CALL iom_close( inum0 )351 CASE ( 2 )352 CALL iom_close( inum1 )353 CALL iom_close( inum2 )354 CASE ( 0 )355 CALL iom_close( inum2 )356 CALL iom_close( inum3 )357 CALL iom_close( inum4 )358 END SELECT359 !360 CALL wrk_dealloc( jpi, jpj, zprt, zprw )361 CALL wrk_dealloc( jpi, jpj, jpk, zdepu, zdepv )362 !363 IF( nn_timing == 1 ) CALL timing_stop('dom_wri')364 !365 184 END SUBROUTINE dom_wri 366 185 … … 375 194 !! 2) check which elements have been changed 376 195 !!---------------------------------------------------------------------- 377 !378 196 CHARACTER(len=1) , INTENT(in ) :: cdgrd ! 379 197 REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! … … 382 200 INTEGER :: ji ! dummy loop indices 383 201 LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! store whether each point is unique or not 384 REAL(wp), POINTER, DIMENSION(:,:) :: ztstref 385 !!---------------------------------------------------------------------- 386 ! 387 IF( nn_timing == 1 ) CALL timing_start('dom_uniq') 388 ! 389 CALL wrk_alloc( jpi, jpj, ztstref ) 202 REAL(wp), DIMENSION(jpi,jpj) :: ztstref 203 !!---------------------------------------------------------------------- 390 204 ! 391 205 ! build an array with different values for each element … … 396 210 ! 397 211 puniq(:,:) = ztstref(:,:) ! default definition 398 CALL lbc_lnk( puniq, cdgrd, 1. ) ! apply boundary conditions212 CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. ) ! apply boundary conditions 399 213 lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed 400 214 ! … … 402 216 ! fill only the inner part of the cpu with llbl converted into real 403 217 puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp ) 404 !405 CALL wrk_dealloc( jpi, jpj, ztstref )406 !407 IF( nn_timing == 1 ) CALL timing_stop('dom_uniq')408 218 ! 409 219 END SUBROUTINE dom_uniq … … 461 271 END DO 462 272 END DO 463 CALL lbc_lnk( zx1, 'T', 1. )273 CALL lbc_lnk( 'domwri', zx1, 'T', 1. ) 464 274 ! 465 275 IF( PRESENT( px1 ) ) px1 = zx1 … … 467 277 zrxmax = MAXVAL( zx1 ) 468 278 ! 469 IF( lk_mpp ) CALL mpp_max(zrxmax ) ! max over the global domain279 CALL mpp_max( 'domwri', zrxmax ) ! max over the global domain 470 280 ! 471 281 IF(lwp) THEN
Note: See TracChangeset
for help on using the changeset viewer.
