- Timestamp:
- 2013-02-28T14:31:33+01:00 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
r3779 r3823 12 12 USE crs_dom ! Coarse grid domain 13 13 USE phycst, ONLY: omega, rad ! physical constants 14 !USE wrk_nemo14 USE wrk_nemo 15 15 USE in_out_manager 16 16 USE par_kind, ONLY: wp … … 18 18 USE crsdomwri 19 19 USE crslbclnk 20 USE lib_mpp 20 21 21 22 IMPLICIT NONE … … 63 64 !!------------------------------------------------------------------- 64 65 !! Local variables 65 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje 66 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices 66 67 INTEGER :: ierr ! allocation error status 67 68 REAL(wp) :: zrestx, zresty ! for determining odd or even reduction factor 68 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmbk 69 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zfse3t, zfse3u, zfse3v, zfse3f 70 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zfse3w, zfse3t_n, zfse3t_b 69 REAL(wp), DIMENSION(:,:) , POINTER :: zmbk 70 REAL(wp), DIMENSION(:,:,:), POINTER :: zfse3t, zfse3u, zfse3v, zfse3w 71 71 LOGICAL :: llok 72 72 … … 96 96 WRITE(numout,*) ' nn_msh_crs = ', nn_msh_crs 97 97 ENDIF 98 98 99 99 rfactx_r = 1./nn_factx 100 100 rfacty_r = 1./nn_facty … … 107 107 jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj 108 108 jpiglo_crsm1 = jpiglo_crs - 1 109 jpjglo_crsm1 = jpjglo_crs - 1 110 jpkm1 = jpk - 1 109 jpjglo_crsm1 = jpjglo_crs - 1 111 110 112 111 ! 2.b. Define local domain indices 113 jpi_crs = ( jpiglo_crs-2 *jpreci + (jpni-1) ) / jpni + 2*jpreci114 jpj_crs = ( jpjglo_crs-2 *jprecj + (jpnj-1) ) / jpnj + 2*jprecj115 jpi_crsm1 = jpi_crs - 1116 jp j_crsm1 = jpj_crs - 1117 112 jpi_crs = ( jpiglo_crs-2 * jpreci + (jpni-1) ) / jpni + 2*jpreci 113 jpj_crs = ( jpjglo_crs-2 * jprecj + (jpnj-1) ) / jpnj + 2*jprecj 114 115 jpi_crsm1 = jpi_crs - 1 116 jpj_crsm1 = jpj_crs - 1 118 117 nperio_crs = jperio 119 118 npolj_crs = npolj 120 121 IF ( jpnij == 1 ) THEN 122 jpnij_crs = jpnij 123 narea_crs = narea 124 nimpp_crs = nimpp 125 njmpp_crs = njmpp 119 120 ierr = crs_dom_alloc() ! allocate most coarse grid arrays 121 122 IF( .NOT. lk_mpp ) THEN 123 nimpp_crs = 1 124 njmpp_crs = 1 125 nlci_crs = jpi_crs 126 nlcj_crs = jpj_crs 127 nldi_crs = 1 128 nldj_crs = 1 129 nlei_crs = jpi_crs 130 nlej_crs = jpj_crs 131 126 132 ELSE 127 WRITE(numout,*) 'crsini.F90. mpp not supported... Stopping' 128 STOP 129 ENDIF 130 131 nlcj_crs = jpj_crs 132 nlci_crs = jpi_crs 133 nldi_crs = 1 134 nlei_crs = jpi_crs 135 nlej_crs = jpj_crs 136 nldj_crs = 1 133 ! Initialisation of most local variables - 134 nimpp_crs = 1 135 njmpp_crs = 1 136 nlci_crs = jpi_crs 137 nlcj_crs = jpj_crs 138 nldi_crs = 1 139 nldj_crs = 1 140 nlei_crs = jpi_crs 141 nlej_crs = jpj_crs 142 143 SELECT CASE ( npolj ) 144 145 CASE ( 0 ) 146 147 nlej_crs = AINT( REAL( ( jpjglo - (njmpp - 1) ) / nn_facty, wp ) ) & 148 & - AINT( REAL( ( jpjglo - mjg(nlej-1) ) / nn_facty, wp ) ) 149 IF( noso == -1 ) THEN 150 IF( MOD( jpjglo - njmpp , nn_facty ) > 0 ) nlej_crs = nlej_crs + 1 151 ELSE 152 IF( MOD( jpjglo - njmpp + 1 , nn_facty ) > nn_facty / 2 ) nlej_crs = nlej_crs + 1 153 ENDIF 154 155 CASE ( 3, 4, 5, 6 ) 156 157 nlej_crs = AINT( REAL( ( jpjglo - (njmpp - 1) ) / nn_facty, wp ) ) & 158 & - AINT( REAL( ( jpjglo - mjg(nlej) + 1 ) / nn_facty, wp ) ) + 1 159 160 CASE DEFAULT 161 WRITE(numout,*) 'crs_init. Only jperio =0, 3, 4, 5, 6 supported' 162 STOP 163 END SELECT 164 165 IF (noso > -1) THEN 166 nlej_crs = nlej_crs + 1 167 nldj_crs = 2 168 ELSE 169 nldj_crs = 1 170 ENDIF 171 172 IF ( nono < jpnj ) THEN 173 nlcj_crs = nlej_crs + 1 174 ELSE 175 nlcj_crs = nlej_crs 176 ENDIF 177 178 njmpp_crs = jpjglo_crs - ANINT( REAL( (jpjglo - njmpp ) / nn_facty, wp ) ) - 1 179 IF( MOD( jpjglo - njmpp , nn_facty ) > nn_facty / 2 ) njmpp_crs = njmpp_crs - 1 180 181 ENDIF 182 183 CALL dom_grid_crs !swich de grille 184 137 185 138 186 IF (lwp) THEN 139 187 WRITE(numout,*) 140 188 WRITE(numout,*) 'crs_init : coarse grid dimensions' 141 WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo_crs = ', jpjglo_crs 142 WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo_crs = ', jpiglo_crs 143 WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi_crs = ', jpi_crs 144 WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj_crs = ', jpj_crs 189 WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo 190 WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo 191 WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi 192 WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj 193 WRITE(numout,*) 194 WRITE(numout,*) ' nproc = ', narea 195 WRITE(numout,*) ' nlci = ', nlci 196 WRITE(numout,*) ' nlcj = ', nlcj 197 WRITE(numout,*) ' nldi = ', nldi 198 WRITE(numout,*) ' nldj = ', nldj 199 WRITE(numout,*) ' nlei = ', nlei 200 WRITE(numout,*) ' nlej = ', nlej 201 WRITE(numout,*) ' nimpp = ', nimpp 202 WRITE(numout,*) ' njmpp = ', njmpp 203 WRITE(numout,*) 145 204 ENDIF 146 147 205 206 CALL dom_grid_glo 207 148 208 mxbinctr = INT( nn_factx * 0.5 ) 149 209 mybinctr = INT( nn_facty * 0.5 ) … … 169 229 170 230 !jes. TODO Need to deallocate these if ln_crs = F 171 ierr = crs_dom_alloc() ! allocate most coarse grid arrays231 172 232 173 233 ! jes. TODO. Add the next two lines when mpp is done … … 181 241 mjs_crs(:) = 0; mje_crs(:) = 0 182 242 243 183 244 SELECT CASE ( cn_binref ) 184 245 185 246 CASE ( 'NORTH' ) 186 247 187 SELECT CASE ( nperio ) 248 SELECT CASE ( npolj ) 249 !cc 250 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 251 252 DO ji = 2, jpiglo_crsm1 253 ijie = (ji*nn_factx)-nn_factx !cc 254 ijis = ijie-nn_factx+1 255 mis_crs(ji) = ijis 256 mie_crs(ji) = ijie 257 ENDDO 258 IF ( jpiglo - 1 - mie_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo-2 ! ijie = jpiglo-1 !cc 259 260 ! Handle first the northernmost bin 261 IF ( nn_facty == 2 ) THEN ; ijjgloT = jpjglo - 1 262 ELSE ; ijjgloT = jpjglo 263 ENDIF 264 265 DO jj = 2, jpjglo_crsm1 266 ijje = ijjgloT-nn_facty*(jj-2) 267 ijjs = ijje-nn_facty+1 268 mjs_crs(jpjglo_crs-jj+1) = ijjs 269 mje_crs(jpjglo_crs-jj+1) = ijje 270 ENDDO 188 271 189 272 CASE ( 2 ) 190 273 WRITE(numout,*) 'crs_init, jperio=2 not supported' 191 274 192 CASE ( 3, 4 ) ! T-Pivot at North Fold275 CASE ( 5, 6 ) ! F-pivot at North Fold 193 276 194 277 DO ji = 2, jpiglo_crsm1 195 !cc ijie = (ji*nn_factx)-nn_factx+1 196 ijie = (ji*nn_factx)-nn_factx !cc 278 ijie = (ji*nn_factx)-nn_factx 197 279 ijis = ijie-nn_factx+1 198 199 IF ( ji == jpiglo_crsm1 ) THEN 200 IF ( ((jpiglo-1)-ijie) <= nn_factx ) ijie = jpiglo-2 ! ijie = jpiglo-1 !cc 201 ENDIF 202 203 ! Handle first the northernmost bin 204 IF ( nn_facty == 2 ) THEN 205 ijjgloT=jpjglo-1 206 ELSE 207 ijjgloT=jpjglo 208 ENDIF 209 210 DO jj = 2, jpjglo_crsm1 211 ! cc ijje = ijjgloT-nn_facty*(jj-2) 212 ijje = ijjgloT-nn_facty*(jj-2) - 1 213 ijjs = ijje-nn_facty+1 214 215 IF ( ijjs <= nn_facty ) ijjs = 2 216 217 mis_crs(ji) = ijis 218 mie_crs(ji) = ijie 219 mjs_crs(jpjglo_crs-jj+1) = ijjs 220 mje_crs(jpjglo_crs-jj+1) = ijje 221 222 ENDDO 223 ENDDO 224 225 CASE ( 5, 6 ) ! F-pivot at North Fold 226 227 DO ji = 2, jpiglo_crsm1 228 ijie = (ji*nn_factx)-nn_factx+1 229 ijis = ijie-nn_factx+1 230 231 IF ( ji == jpiglo_crsm1 ) THEN 232 IF ( ((jpiglo-1)-ijie) <= nn_factx ) ijie = jpiglo-1 233 ENDIF 234 235 ! Treat the northernmost bin separately. 236 jj = 2 237 ijje = jpjglo-nn_facty*(jj-2) 238 IF ( nn_facty == 3 ) THEN 239 ijjs=ijje-1 240 ELSE 241 ijjs=ijje-nn_facty+1 242 ENDIF 243 244 mis_crs(ji) = ijis 245 mie_crs(ji) = ijie 246 mjs_crs(jpjglo_crs-jj+1) = ijjs 247 mje_crs(jpjglo_crs-jj+1) = ijje 248 249 ! Now bin the rest, any remainder at the south is lumped in the southern bin 250 DO jj = 3, jpjglo_crsm1 251 252 ijje = jpjglo-nn_facty*(jj-2) 253 ijjs = ijje-nn_facty+1 254 255 IF ( ijjs <= nn_facty ) ijjs = 2 256 257 mis_crs(ji) = ijis 258 mie_crs(ji) = ijie 259 mjs_crs(jpjglo_crs-jj+1) = ijjs 260 mje_crs(jpjglo_crs-jj+1) = ijje 261 ENDDO 280 mis_crs(ji) = ijis 281 mie_crs(ji) = ijie 262 282 ENDDO 283 IF ( jpiglo - 1 - mie_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo-2 ! ijie = jpiglo-1 !cc 284 285 ! Treat the northernmost bin separately. 286 jj = 2 287 ijje = jpj-nn_facty*(jj-2) 288 IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 1 289 ELSE ; ijjs = ijje - nn_facty + 1 290 ENDIF 291 mjs_crs(jpj_crs-jj+1) = ijjs 292 mje_crs(jpj_crs-jj+1) = ijje 293 294 ! Now bin the rest, any remainder at the south is lumped in the southern bin 295 DO jj = 3, jpjglo_crsm1 296 ijje = jpjglo-nn_facty*(jj-2) 297 ijjs = ijje-nn_facty+1 298 IF ( ijjs <= nn_facty ) ijjs = 2 299 mjs_crs(jpj_crs-jj+1) = ijjs 300 mje_crs(jpj_crs-jj+1) = ijje 301 ENDDO 263 302 264 303 CASE DEFAULT 265 WRITE(numout,*) 'crs_init. Only jperio = 3, 4, 5, 6 supported'304 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' 266 305 267 306 END SELECT … … 271 310 272 311 END SELECT 312 273 313 274 314 ! Pad the boundaries, do not know if it is necessary 275 315 mis_crs(1) = 1 ; mis_crs(jpiglo_crs) = mie_crs(jpiglo_crs - 1) + 1 !cc 276 316 mie_crs(1) = nn_factx ; mie_crs(jpiglo_crs) = jpiglo !cc 277 mjs_crs(1) = 1 ; mjs_crs(jpjglo_crs) = mje_crs(jpjglo_crs - 1) + 1 317 ! Probleme de segmentation je sais pas pourquoi 318 mjs_crs(1) = 1 ; mjs_crs(jpjglo_crs) = mje_crs(jpjglo_crsm1) + 1 278 319 mje_crs(1) = mjs_crs(2)-1; mje_crs(jpjglo_crs) = jpjglo 279 320 280 ! WRITE(numout,*) 'crs_init. coarse grid bounds on parent grid' 281 ! WRITE(numout,'(1x,a,62(1x,i3),/)') 'mis_crs=', mis_crs 282 ! WRITE(numout,'(1x,a,62(1x,i3),/)') 'mie_crs=', mie_crs 283 ! WRITE(numout,'(1x,a,51(1x,i3),/)') 'mjs_crs=', mjs_crs 284 ! WRITE(numout,'(1x,a,51(1x,i3),/)') 'mje_crs=', mje_crs 285 286 321 ! WRITE(numout,*) 'crs_init. coarse grid bounds on parent grid' 322 ! WRITE(numout,*) 'mis_crs=', mis_crs 323 ! WRITE(numout,*) 'mie_crs=', mie_crs 324 ! WRITE(numout,*) 'mjs_crs=', mjs_crs 325 ! WRITE(numout,*) 'mje_crs=', mje_crs 326 327 328 IF( .NOT. lk_mpp ) THEN 329 njstart = 1 ; njend = jpj_crsm1 330 ELSE 331 ! 332 IF( noso == -1 ) THEN ; njstart = 1 333 ELSE ; njstart = 2 334 ENDIF 335 ! 336 IF( mje_crs(nlej_crs) >= jpj ) THEN ; njend = nlej_crs - 1 337 ELSE ; njend = nlej_crs 338 ENDIF 339 ! 340 ENDIF 341 287 342 !--------------------------------------------------------- 288 343 ! 3. Mask and Mesh … … 310 365 311 366 CALL crsfun( gphit, glamt, 'T', gphit_crs, glamt_crs ) 312 WRITE(numout,*) 'crsini. gphit_crs(15,15)', gphit_crs(15,15)313 WRITE(numout,*) 'crsini. glamt_crs(15,15)', glamt_crs(15,15)314 315 WRITE(numout,*) 'crsini. count 1'367 ! WRITE(numout,*) 'crsini. gphit_crs(15,15)', gphit_crs(15,15) 368 ! WRITE(numout,*) 'crsini. glamt_crs(15,15)', glamt_crs(15,15) 369 370 ! WRITE(numout,*) 'crsini. count 1' 316 371 317 372 CALL crsfun( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) !cc 318 WRITE(numout,*) 'crsini. gphiu_crs(15,15)', gphiu_crs(15,15) !cc319 WRITE(numout,*) 'crsini. glamu_crs(15,15)', glamu_crs(15,15) !cc320 WRITE(numout,*) 'crsini. count 2'373 ! WRITE(numout,*) 'crsini. gphiu_crs(15,15)', gphiu_crs(15,15) !cc 374 ! WRITE(numout,*) 'crsini. glamu_crs(15,15)', glamu_crs(15,15) !cc 375 ! WRITE(numout,*) 'crsini. count 2' 321 376 322 377 CALL crsfun( p_pgphi=gphiv, p_pglam=glamv, cd_type='V', p_cgphi=gphiv_crs, p_cglam=glamv_crs ) !cc 323 WRITE(numout,*) 'crsini. gphiv_crs(15,15)', gphiv_crs(15,15) !cc324 WRITE(numout,*) 'crsini. glamv_crs(15,15)', glamv_crs(15,15) !cc325 326 WRITE(numout,*) 'crsini. count 3'378 ! WRITE(numout,*) 'crsini. gphiv_crs(15,15)', gphiv_crs(15,15) !cc 379 ! WRITE(numout,*) 'crsini. glamv_crs(15,15)', glamv_crs(15,15) !cc 380 381 ! WRITE(numout,*) 'crsini. count 3' 327 382 CALL crsfun( p_pgphi=gphif, p_pglam=glamf, cd_type='F', p_cgphi=gphif_crs, p_cglam=glamf_crs ) !cc 328 WRITE(numout,*) 'crsini. gphif_crs(15,15)', gphif_crs(15,15) !cc329 WRITE(numout,*) 'crsini. glamf_crs(15,15)', glamf_crs(15,15) !cc330 331 WRITE(numout,*) 'crsini. count 4'383 ! WRITE(numout,*) 'crsini. gphif_crs(15,15)', gphif_crs(15,15) !cc 384 ! WRITE(numout,*) 'crsini. glamf_crs(15,15)', glamf_crs(15,15) !cc 385 386 ! WRITE(numout,*) 'crsini. count 4' 332 387 ELSEIF ( zresty /= 0 .AND. zrestx == 0 ) THEN 333 388 CALL crsfun( p_pgphi=gphiu, p_pglam=glamu, cd_type='T', p_cgphi=gphit_crs, p_cglam=glamt_crs ) … … 406 461 ENDDO 407 462 408 ALLOCATE( zmbk(jpi_crs,jpj_crs))463 CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 409 464 410 465 zmbk(:,:) = 0.0 … … 438 493 439 494 ! 3.d.2 Vertical scale factors 440 441 ALLOCATE( zfse3t(jpi,jpj,jpk), zfse3u(jpi,jpj,jpk), zfse3v(jpi,jpj,jpk), zfse3f(jpi,jpj,jpk), & 442 & zfse3w(jpi,jpj,jpk), zfse3t_n(jpi,jpj,jpk), zfse3t_b(jpi,jpj,jpk) ) 495 CALL wrk_alloc(jpi, jpj, jpk, zfse3t, zfse3u, zfse3v, zfse3w ) 496 ! 443 497 zfse3t(:,:,:) = fse3t(:,:,:) 444 498 zfse3u(:,:,:) = fse3u(:,:,:) 445 499 zfse3v(:,:,:) = fse3v(:,:,:) 446 zfse3f(:,:,:) = fse3f(:,:,:)447 500 zfse3w(:,:,:) = fse3w(:,:,:) 448 501 449 502 450 451 !CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, p_pfield3d_1=zfse3t, p_cfield3d=e3t_crs ) 452 !CALL crsfun( p_e1e2t=e1e2t, cd_type='W', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, p_pfield3d_1=zfse3w, p_cfield3d=e3w_crs ) 503 WRITE(numout,*) 'crs_init : beginning section 3.d.2 ! ' 504 !CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='MAX', p_cmask=tmask_crs, & 505 ! & p_ptmask=tmask, p_pfield3d_1=zfse3t, p_cfield3d=e3t_crs ) 506 !CALL crsfun( p_e1e2t=e1e2t, cd_type='W', cd_op='MAX', p_cmask=tmask_crs, & 507 ! & p_ptmask=tmask, p_pfield3d_1=zfse3w, p_cfield3d=e3w_crs ) 453 508 !CALL crsfun( p_e1e2t=e1e2t, cd_type='U', cd_op='MIN', p_cmask=umask_crs, p_ptmask=umask, p_pfield3d_1=zfse3u, p_cfield3d=e3u_crs ) 454 509 !CALL crsfun( p_e1e2t=e1e2t, cd_type='V', cd_op='MIN', p_cmask=vmask_crs, p_ptmask=vmask, p_pfield3d_1=zfse3v, p_cfield3d=e3v_crs ) 455 510 !CALL crsfun( p_e1e2t=e1e2t, cd_type='F', cd_op='MIN', p_cmask=fmask_crs, p_ptmask=fmask, p_pfield3d_1=zfse3f, p_cfield3d=e3f_crs ) 511 456 512 CALL crs_e3_max( p_e3=zfse3t, cd_type='T', p_mask=tmask, p_e3_crs=e3t_crs) 457 513 CALL crs_e3_max( p_e3=zfse3w, cd_type='W', p_mask=tmask, p_e3_crs=e3w_crs) 514 515 WRITE(numout,*) 'crs_init : crs_e3_max ' 516 458 517 459 518 ! Reset 0 to e3t_0 or e3w_0 … … 522 581 ! 7. Finish and clean-up 523 582 !--------------------------------------------------------- 524 DEALLOCATE( zmbk ) 525 DEALLOCATE( zfse3t, zfse3u, zfse3v, zfse3f ) 526 DEALLOCATE( zfse3w, zfse3t_n, zfse3t_b ) 527 528 583 CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk ) 584 CALL wrk_dealloc(jpi, jpj, jpk, zfse3t, zfse3u, zfse3v, zfse3w ) 585 586 529 587 END SUBROUTINE crs_init 530 588
Note: See TracChangeset
for help on using the changeset viewer.
