- Timestamp:
- 2016-07-01T18:02:45+02:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
r6101 r6772 38 38 USE crslbclnk 39 39 USE lib_mpp 40 !cbrUSE ieee_arithmetic40 USE ieee_arithmetic 41 41 42 42 IMPLICIT NONE … … 61 61 62 62 SUBROUTINE crs_dom_msk 63 !!=================================================================== 64 ! 65 ! 66 ! 67 !!=================================================================== 68 INTEGER :: ji, jj, jk ! dummy loop indices 69 INTEGER :: ijis,ijie,ijjs,ijje 70 REAL(wp) :: zmask 71 !!------------------------------------------------------------------- 63 72 64 INTEGER :: ji, jj, jk ! dummy loop indices 65 INTEGER :: ijie,ijis,ijje,ijjs,ij,je_2 66 INTEGER :: iji, ijj 67 REAL(wp) :: zmask 68 INTEGER :: ir,jr 69 70 ! Initialize 71 tmask_crs(:,:,:) = 0.0 72 vmask_crs(:,:,:) = 0.0 73 umask_crs(:,:,:) = 0.0 74 fmask_crs(:,:,:) = 0.0 75 ! 76 DO jk = 1, jpkm1 77 DO ji = 2, nlei_crs 78 ijie = mie_crs(ji) 79 ijis = mis_crs(ji) 80 81 IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN !!cc bande du sud style ORCA2 82 83 IF( mje_crs(2) - mjs_crs(2) == 1 )THEN 84 85 jj = mje_crs(2) 86 87 zmask = 0.0 88 zmask = SUM( tmask(ijis:ijie,jj,jk) ) 89 IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 90 91 zmask = 0.0 92 zmask = SUM( vmask(ijis:ijie,jj ,jk) ) 93 IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 94 95 zmask = 0.0 96 zmask = umask(ijie ,jj,jk) 97 IF( zmask > 0.0 )umask_crs(ji,2,jk) = 1.0 98 99 fmask_crs(ji,jj,jk) = fmask(ijie,2,jk) 100 ENDIF 101 ELSE 102 103 jj = mje_crs(2) 104 ij = mjs_crs(2) 105 106 zmask = 0.0 107 zmask = SUM( tmask(ijis:ijie,ij:jj,jk) ) 108 IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 109 110 zmask = 0.0 111 zmask = SUM( vmask(ijis:ijie,jj ,jk) ) 112 IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 113 114 zmask = 0.0 115 zmask = SUM(umask(ijie,ij:jj,jk)) 116 IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0 117 118 fmask_crs(ji,jj,jk) = fmask(ijie,2,jk) 119 120 ENDIF 121 122 DO jj = 3, nlej_crs 123 ijje = mje_crs(jj) 124 ijjs = mjs_crs(jj) 125 126 !iji=117 ; ijj=211 127 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 128 !IF( ji ==iji .AND. jj==ijj .AND. jk==74 )THEN 129 !write(narea+5000,*)"mask ",ji,jj 130 !write(narea+5000,*)"mask ",ijie,ijis,ijjs,ijje 131 !ENDIF 132 133 ir=303-nimpp_crs+1 ; jr=302-njmpp_crs+1 134 IF( ji==ir .AND. jj==jr )THEN 135 WRITE(narea+2000,*)"mask",ir,jr,ijis+nimpp-1,ijjs+njmpp-1 136 ENDIF 137 138 !IF( ijje .GT. jpj )WRITE(narea+200,*)"BUG",jj,ijjs,ijje,SHAPE(tmask) ; call flush(narea+200) 139 zmask = 0.0 140 zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 141 IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 142 143 zmask = 0.0 144 zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) 145 IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 146 147 zmask = 0.0 148 zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) 149 IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 150 151 fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) 152 153 ENDDO 73 ! Initialize 74 tmask_crs(:,:,:) = 0.0 75 vmask_crs(:,:,:) = 0.0 76 umask_crs(:,:,:) = 0.0 77 fmask_crs(:,:,:) = 0.0 78 ! 79 DO jk = 1, jpkm1 80 DO ji = nldi_crs, nlei_crs 81 82 ijis = mis_crs(ji) 83 ijie = mie_crs(ji) 84 85 DO jj = nldj_crs, nlej_crs 86 87 ijjs = mjs_crs(jj) 88 ijje = mje_crs(jj) 89 90 zmask = 0.0 91 zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 92 IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 93 94 zmask = 0.0 95 zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) 96 IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 97 98 zmask = 0.0 99 zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) 100 IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 101 102 fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) 103 104 154 105 ENDDO 155 106 ENDDO 156 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) 157 !cbr 158 !DO ji=1,jpi_crs-1 159 !DO jj=1,jpj_crs-1 160 !DO jk=1,jpk 161 ! umask_crs(ji,jj,jk) = tmask_crs(ji ,jj ,jk) * tmask_crs(ji+1,jj ,jk) 162 ! vmask_crs(ji,jj,jk) = tmask_crs(ji ,jj ,jk) * tmask_crs(ji ,jj+1,jk) 163 ! fmask_crs(ji,jj,jk) = tmask_crs(ji ,jj ,jk) * tmask_crs(ji ,jj+1,jk) * tmask_crs(ji+1,jj ,jk) * tmask_crs(ji+1,jj+1,jk) 164 !ENDDO 165 !ENDDO 166 !ENDDO 167 ! 168 CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) 169 CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) 170 CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) 171 ! 172 !cbr 173 !DO ji=2,jpi_crs-1 174 !DO jj=2,jpj_crs-1 175 !DO jk=1,jpk 176 ! IF( tmask(ji-1,jj ,jk)==1. .AND. tmask(ji ,jj ,jk)==1. .AND. umask(ji-1,jj ,jk)==0. )WRITE(narea+5000,*)"MASK1",ji,jj,jk 177 ! IF( tmask(ji ,jj ,jk)==1. .AND. tmask(ji+1,jj ,jk)==1. .AND. umask(ji ,jj ,jk)==0. )WRITE(narea+5000,*)"MASK2",ji,jj,jk 178 ! IF( tmask(ji ,jj-1,jk)==1. .AND. tmask(ji ,jj ,jk)==1. .AND. vmask(ji ,jj-1,jk)==0. )WRITE(narea+5000,*)"MASK3",ji,jj,jk 179 ! IF( tmask(ji ,jj ,jk)==1. .AND. tmask(ji ,jj+1,jk)==1. .AND. vmask(ji ,jj ,jk)==0. )WRITE(narea+5000,*)"MASK4",ji,jj,jk 180 ! IF( umask(ji-1,jj ,jk)==1. .AND. ( tmask(ji-1,jj ,jk)==0. .OR. tmask(ji ,jj ,jk)==0. ) )WRITE(narea+5000,*)"MASK5",ji,jj,jk 181 ! IF( umask(ji ,jj ,jk)==1. .AND. ( tmask(ji ,jj ,jk)==0. .OR. tmask(ji+1,jj ,jk)==0. ) )WRITE(narea+5000,*)"MASK6",ji,jj,jk 182 ! IF( vmask(ji ,jj-1,jk)==1. .AND. ( tmask(ji ,jj-1,jk)==0. .OR. tmask(ji ,jj ,jk)==0. ) )WRITE(narea+5000,*)"MASK7",ji,jj,jk 183 ! IF( vmask(ji ,jj ,jk)==1. .AND. ( tmask(ji ,jj ,jk)==0. .OR. tmask(ji ,jj+1,jk)==0. ) )WRITE(narea+5000,*)"MASK8",ji,jj,jk 184 !ENDDO 185 !ENDDO 186 !ENDDO 187 ! 107 ENDDO 108 109 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) 110 CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) 111 CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) 112 CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) 113 ! 188 114 END SUBROUTINE crs_dom_msk 189 115 … … 219 145 !! Local variables 220 146 INTEGER :: ji, jj, jk ! dummy loop indices 221 INTEGER :: iji s, ijjs147 INTEGER :: iji, ijj 222 148 INTEGER :: ir,jr 149 !!---------------------------------------------------------------- 150 p_gphi_crs(:,:)=0._wp 151 p_glam_crs(:,:)=0._wp 223 152 224 153 … … 226 155 CASE ( 'T' ) 227 156 DO jj = nldj_crs, nlej_crs 228 ijjs = mjs_crs(jj) + mybinctr 229 DO ji = 2, nlei_crs 230 ijis = mis_crs(ji) + mxbinctr 231 p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 232 p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 233 ir=303-nimpp_crs+1 ; jr=302-njmpp_crs+1 234 WRITE(narea+2000,*)"coordT1",ir,jr 235 IF( ji==ir .AND. jj==jr )THEN 236 WRITE(narea+2000,*)"coordT",ir,jr,ijis+nimpp-1,ijjs+njmpp-1 237 ENDIF 157 ijj = mjs_crs(jj) + 1 158 DO ji = nldi_crs, nlei_crs 159 iji = mis_crs(ji) + 1 160 p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 161 p_glam_crs(ji,jj) = p_glam(iji,ijj) 238 162 ENDDO 239 163 ENDDO 240 164 CASE ( 'U' ) 241 165 DO jj = nldj_crs, nlej_crs 242 ijjs = mjs_crs(jj) + mybinctr 243 DO ji = 2, nlei_crs 244 ijis = mis_crs(ji) 245 p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 246 p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 166 ijj = mjs_crs(jj) + 1 167 DO ji = nldi_crs, nlei_crs 168 iji = mie_crs(ji) 169 p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 170 p_glam_crs(ji,jj) = p_glam(iji,ijj) 171 247 172 ENDDO 248 173 ENDDO 249 174 CASE ( 'V' ) 250 175 DO jj = nldj_crs, nlej_crs 251 ijj s = mjs_crs(jj)252 DO ji = 2, nlei_crs253 iji s = mis_crs(ji) + mxbinctr254 p_gphi_crs(ji,jj) = p_gphi(iji s,ijjs)255 p_glam_crs(ji,jj) = p_glam(iji s,ijjs)176 ijj = mje_crs(jj) 177 DO ji = nldi_crs, nlei_crs 178 iji = mis_crs(ji) + 1 179 p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 180 p_glam_crs(ji,jj) = p_glam(iji,ijj) 256 181 ENDDO 257 182 ENDDO 258 183 CASE ( 'F' ) 259 184 DO jj = nldj_crs, nlej_crs 260 ijj s = mjs_crs(jj)261 DO ji = 2, nlei_crs262 iji s = mis_crs(ji)263 p_gphi_crs(ji,jj) = p_gphi(iji s,ijjs)264 p_glam_crs(ji,jj) = p_glam(iji s,ijjs)185 ijj = mje_crs(jj) 186 DO ji = nldi_crs, nlei_crs 187 iji = mie_crs(ji) 188 p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 189 p_glam_crs(ji,jj) = p_glam(iji,ijj) 265 190 ENDDO 266 191 ENDDO … … 271 196 CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 ) 272 197 273 ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd274 SELECT CASE ( cd_type )275 CASE ( 'T', 'V' )276 DO ji = 2, nlei_crs277 ijis = mis_crs(ji) + mxbinctr278 p_gphi_crs(ji,1) = p_gphi(ijis,1)279 p_glam_crs(ji,1) = p_glam(ijis,1)280 ENDDO281 CASE ( 'U', 'F' )282 DO ji = 2, nlei_crs283 ijis = mis_crs(ji)284 p_gphi_crs(ji,1) = p_gphi(ijis,1)285 p_glam_crs(ji,1) = p_glam(ijis,1)286 ENDDO287 END SELECT198 !cbr??? ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 199 ! SELECT CASE ( cd_type ) 200 ! CASE ( 'T', 'V' ) 201 ! DO ji = 2, nlei_crs 202 ! ijis = mis_crs(ji) + mxbinctr 203 ! p_gphi_crs(ji,1) = p_gphi(ijis,1) 204 ! p_glam_crs(ji,1) = p_glam(ijis,1) 205 ! ENDDO 206 ! CASE ( 'U', 'F' ) 207 ! DO ji = 2, nlei_crs 208 ! ijis = mis_crs(ji) 209 ! p_gphi_crs(ji,1) = p_gphi(ijis,1) 210 ! p_glam_crs(ji,1) = p_glam(ijis,1) 211 ! ENDDO 212 ! END SELECT 288 213 ! 289 214 END SUBROUTINE crs_dom_coordinates … … 317 242 !! Local variables 318 243 INTEGER :: ji, jj, jk ! dummy loop indices 319 INTEGER :: ijie,ijje,ijrs 244 INTEGER :: ijis,ijie,ijjs,ijje 245 INTEGER :: ji1, jj1 320 246 321 247 !!---------------------------------------------------------------- 322 248 ! Initialize 323 249 324 DO jk = 1, jpk 325 DO ji = 2, nlei_crs 250 DO ji = nldi_crs, nlei_crs 251 252 ijis = mis_crs(ji) 326 253 ijie = mie_crs(ji) 254 327 255 DO jj = nldj_crs, nlej_crs 328 ijje = mje_crs(jj) ; ijrs = mje_crs(jj) - mjs_crs(jj) 256 257 ijjs = mjs_crs(jj) 258 ijje = mje_crs(jj) 259 329 260 ! Only for a factro 3 coarsening 330 261 SELECT CASE ( cd_type ) 331 262 CASE ( 'T' ) 332 IF( ijrs == 0 .OR. ijrs == 1 ) THEN 333 ! Si à la frontière sud on a pas assez de maille de la grille mère 334 p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx 335 p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty 336 ELSE 337 p_e1_crs(ji,jj) = p_e1(ijie-1,ijje-1) * nn_factx 338 p_e2_crs(ji,jj) = p_e2(ijie-1,ijje-1) * nn_facty 339 ENDIF 263 !p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie ,ijjs+1 ) ) 264 !p_e2_crs(ji,jj) = SUM( p_e2(ijis+1 ,ijjs:ijje ) ) 265 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1) 266 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1) 340 267 CASE ( 'U' ) 341 IF( ijrs == 0 .OR. ijrs == 1 ) THEN 342 ! Si à la frontière sud on a pas assez de maille de la grille mère 343 p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx 344 p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty 345 ELSE 346 p_e1_crs(ji,jj) = p_e1(ijie,ijje-1) * nn_factx 347 p_e2_crs(ji,jj) = p_e2(ijie,ijje-1) * nn_facty 348 ENDIF 268 !p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijjs+1 ) ) 269 !p_e2_crs(ji,jj) = SUM( p_e2(ijie ,ijjs:ijje ) ) 270 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1 ) 271 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+1 ) 272 349 273 CASE ( 'V' ) 350 p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx 351 p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty 274 !p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie ,ijje ) ) 275 !p_e2_crs(ji,jj) = SUM( p_e2(ijis+1 ,ijjs+1:ijje+1) ) 276 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje ) 277 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1 ) 352 278 CASE ( 'F' ) 353 p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx 354 p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty 279 !p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijje ) ) 280 !p_e2_crs(ji,jj) = SUM( p_e2(ijie ,ijjs+1:ijje+1) ) 281 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje ) 282 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+1 ) 355 283 END SELECT 356 284 ENDDO 357 285 ENDDO 358 ENDDO 359 360 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 , pval=1.0 )361 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 , pval=1.0 )286 287 288 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 ) !cbr , pval=1.0 ) 289 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 ) !cbr , pval=1.0 ) 362 290 363 291 END SUBROUTINE crs_dom_hgr … … 416 344 !! Local variables 417 345 REAL(wp) :: zdAm 418 INTEGER :: ji, jj, jk , ii, ij, je_2 346 INTEGER :: ji, jj, jk 347 INTEGER :: ijis,ijie,ijjs,ijje 419 348 420 349 REAL(wp), DIMENSION(:,:,:), POINTER :: zvol, zmask … … 427 356 428 357 DO jk = 1, jpk 429 zvol(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 358 zvol (:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 359 zmask(:,:,jk) = p_mask(:,:,jk) 430 360 ENDDO 431 361 432 zmask(:,:,:) = 0.0 433 !IF( cd_type == 'W' ) THEN 434 ! zmask(:,:,1) = p_mask(:,:,1) 435 ! DO jk = 2, jpk 436 ! zmask(:,:,jk) = p_mask(:,:,jk-1) 437 ! ENDDO 438 !ELSE 439 DO jk = 1, jpk 440 zmask(:,:,jk) = p_mask(:,:,jk) 441 ENDDO 442 !ENDIF 443 444 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 445 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 446 je_2 = mje_crs(2) 447 DO jk = 1, jpk 448 DO ji = nistr, niend, nn_factx 449 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 450 p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & 451 & + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk) 452 ! 453 zdAm = zvol(ji ,je_2,jk) * zmask(ji ,je_2,jk) & 454 & + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & 455 & + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 456 ! 457 p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 458 ENDDO 459 ENDDO 460 ENDIF 461 ELSE 462 je_2 = mjs_crs(2) 463 DO jk = 1, jpk 464 DO ji = nistr, niend, nn_factx 465 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 466 p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & 467 & + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk) & 468 & + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk) 469 ! 470 zdAm = zvol(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & 471 & + zvol(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & 472 & + zvol(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & 473 & + zvol(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & 474 & + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & 475 & + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & 476 & + zvol(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & 477 & + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & 478 & + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) 479 ! 480 p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 481 ENDDO 482 ENDDO 483 ENDIF 484 485 DO jk = 1, jpk 486 DO jj = njstr, njend, nn_facty 487 DO ji = nistr, niend, nn_factx 488 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 489 ij = ( jj - njstr ) * rfacty_r + 3 490 ! 491 p_fld1_crs(ii,ij,jk) = zvol(ji,jj ,jk) + zvol(ji+1,jj ,jk) + zvol(ji+2,jj ,jk) & 492 & + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk) & 493 & + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) 494 ! 495 zdAm = zvol(ji ,jj ,jk) * zmask(ji ,jj ,jk) & 496 & + zvol(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & 497 & + zvol(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & 498 & + zvol(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & 499 & + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & 500 & + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & 501 & + zvol(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & 502 & + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & 503 & + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) 504 ! 505 p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk) 362 DO jk = 1, jpk 363 DO ji = nldi_crs, nlei_crs 364 365 ijis = mis_crs(ji) 366 ijie = mie_crs(ji) 367 368 DO jj = nldj_crs, nlej_crs 369 370 ijjs = mjs_crs(jj) 371 ijje = mje_crs(jj) 372 373 p_fld1_crs(ji,jj,jk) = SUM( zvol(ijis:ijie,ijjs:ijje,jk) ) 374 zdAm = SUM( zvol(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) ) 375 p_fld2_crs(ji,jj,jk) = zdAm / p_fld1_crs(ji,jj,jk) 506 376 ENDDO 507 377 ENDDO … … 551 421 REAL(wp), INTENT(in) :: psgn ! sign 552 422 553 554 423 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity 555 424 556 425 !! Local variables 557 426 INTEGER :: ji, jj, jk 558 INTEGER :: i i, ij, ijie, ijje, je_2427 INTEGER :: ijis, ijie, ijjs, ijje 559 428 REAL(wp) :: zflcrs, zsfcrs 560 429 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask,ztabtmp 561 INTEGER :: iji, ijj562 430 INTEGER :: ir,jr 563 431 REAL(wp), DIMENSION(nn_factx,nn_facty):: ztmp … … 579 447 580 448 CASE( 'T', 'W' ) 581 !IF( cd_type == 'T' ) THEN 582 DO jk = 1, jpk 583 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 584 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 585 ENDDO 586 !ELSE 587 ! !cbr ???????????????????????????????? 588 ! zsurf (:,:,1) = p_e12(:,:) * p_e3(:,:,1) 589 ! zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 590 ! DO jk = 2, jpk 591 ! zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) 592 ! zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 593 ! ENDDO 594 !ENDIF 595 596 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 597 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 598 je_2 = mje_crs(2) 599 DO jk = 1, jpk 600 DO ji = nistr, niend, nn_factx 601 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 602 zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & 603 & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & 604 & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 605 606 zsfcrs = zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 607 ! 608 p_fld_crs(ii,2,jk) = zflcrs 609 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 610 ENDDO 611 ENDDO 612 ENDIF 613 ELSE 614 je_2 = mjs_crs(2) 615 DO jk = 1, jpk 616 DO ji = nistr, niend, nn_factx 617 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 618 zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & 619 & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & 620 & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & 621 & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & 622 & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 623 & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 624 & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & 625 & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 626 & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 627 628 zsfcrs = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 629 & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 630 & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 631 ! 632 p_fld_crs(ii,2,jk) = zflcrs 633 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 634 ENDDO 635 ENDDO 636 ENDIF 449 DO jk = 1, jpk 450 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 451 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 452 ENDDO 637 453 ! 638 DO jk = 1, jpk 639 DO jj = njstr, njend, nn_facty 640 DO ji = nistr, niend, nn_factx 641 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 642 ij = ( jj - njstr ) * rfacty_r + 3 643 zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & 644 & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & 645 & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & 646 & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & 647 & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 648 & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 649 & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & 650 & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 651 & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 652 zsfcrs = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 653 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 654 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 655 ! 656 !cbr IF( ieee_is_nan(p_fld_crs(ii,ij,jk))) THEN 657 658 p_fld_crs(ii,ij,jk) = zflcrs 659 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 454 DO jk = 1, jpk 455 DO jj = nldj_crs,nlej_crs 456 ijjs = mjs_crs(jj) 457 ijje = mje_crs(jj) 458 DO ji = nldi_crs, nlei_crs 459 460 ijis = mis_crs(ji) 461 ijie = mie_crs(ji) 462 463 zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 464 zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 465 466 p_fld_crs(ji,jj,jk) = zflcrs 467 IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs 660 468 ENDDO 661 469 ENDDO 662 470 ENDDO 471 ! 663 472 CASE DEFAULT 664 473 STOP 665 END SELECT 666 667 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 474 END SELECT 475 476 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 477 668 478 CASE ( 'LOGVOL' ) 669 479 670 480 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk, ztabtmp ) 671 672 zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"p_fld",zmin,zmax; CALL flush(numout)673 481 674 482 ztabtmp(:,:,:)=0._wp 675 483 WHERE(p_fld* p_mask .NE. 0._wp ) ztabtmp = LOG10(p_fld * p_mask)*p_mask 676 zmin=MINVAL(ztabtmp) ; zmax=MAXVAL(ztabtmp);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"LOG()",zmin,zmax; CALL flush(numout)677 484 ztabtmp = ztabtmp * p_mask 678 zmin=MINVAL(ztabtmp) ; zmax=MAXVAL(ztabtmp);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"LOG()*tmask",zmin,zmax; CALL flush(numout)679 485 680 486 SELECT CASE ( cd_type ) 681 487 682 488 CASE( 'T', 'W' ) 683 DO jk = 1, jpk 684 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 685 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 686 ENDDO 687 688 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 689 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 690 je_2 = mje_crs(2) 691 DO jk = 1, jpk 692 DO ji = nistr, niend, nn_factx 693 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 694 zflcrs = ztabtmp(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & 695 & + ztabtmp(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & 696 & + ztabtmp(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 697 698 zsfcrs = zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 699 ! 700 p_fld_crs(ii,2,jk) = 0._wp 701 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 702 p_fld_crs(ii,2,jk) = 10 ** ( p_fld_crs(ii,2,jk) * p_mask_crs(ii,2,jk) ) * p_mask_crs(ii,2,jk) 703 ENDDO 704 ENDDO 705 ENDIF 706 ELSE 707 je_2 = mjs_crs(2) 708 DO jk = 1, jpk 709 DO ji = nistr, niend, nn_factx 710 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 711 zflcrs = ztabtmp(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & 712 & + ztabtmp(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & 713 & + ztabtmp(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & 714 & + ztabtmp(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & 715 & + ztabtmp(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 716 & + ztabtmp(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 717 & + ztabtmp(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & 718 & + ztabtmp(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 719 & + ztabtmp(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 720 721 zsfcrs = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 722 & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 723 & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 724 ! 725 p_fld_crs(ii,2,jk) = 0._wp 726 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 727 p_fld_crs(ii,2,jk) = 10 ** ( p_fld_crs(ii,2,jk) * p_mask_crs(ii,2,jk) ) * p_mask_crs(ii,2,jk) 489 490 DO jk = 1, jpk 491 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 492 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 493 ENDDO 494 ! 495 DO jk = 1, jpk 496 DO jj = nldj_crs,nlej_crs 497 ijjs = mjs_crs(jj) 498 ijje = mje_crs(jj) 499 DO ji = nldi_crs, nlei_crs 500 ijis = mis_crs(ji) 501 ijie = mie_crs(ji) 502 zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 503 zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 504 p_fld_crs(ji,jj,jk) = zflcrs 505 IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs 506 p_fld_crs(ji,jj,jk) = 10 ** ( p_fld_crs(ji,jj,jk) * p_mask_crs(ji,jj,jk) ) * p_mask_crs(ji,jj,jk) 728 507 ENDDO 729 508 ENDDO 730 ENDIF 509 ENDDO 510 CASE DEFAULT 511 STOP 512 END SELECT 513 514 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp ) 515 516 CASE ( 'MED' ) 517 518 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 519 520 SELECT CASE ( cd_type ) 521 522 CASE( 'T', 'W' ) 523 DO jk = 1, jpk 524 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 525 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 526 ENDDO 731 527 ! 732 528 DO jk = 1, jpk 733 DO jj = njstr, njend, nn_facty 734 DO ji = nistr, niend, nn_factx 735 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 736 ij = ( jj - njstr ) * rfacty_r + 3 737 zflcrs = ztabtmp(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & 738 & + ztabtmp(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & 739 & + ztabtmp(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & 740 & + ztabtmp(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & 741 & + ztabtmp(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 742 & + ztabtmp(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 743 & + ztabtmp(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & 744 & + ztabtmp(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 745 & + ztabtmp(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 746 zsfcrs = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 747 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 748 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 749 ! 750 p_fld_crs(ii,ij,jk) = 0._wp 751 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 752 p_fld_crs(ii,ij,jk) = 10 ** ( p_fld_crs(ii,ij,jk) * p_mask_crs(ii,ij,jk) ) * p_mask_crs(ii,ij,jk) 753 ENDDO 754 ENDDO 755 ENDDO 756 CASE DEFAULT 757 STOP 758 END SELECT 759 760 761 !WHERE( p_fld .NE. 0._wp ) p_fld=10**(p_fld) 762 !zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld)",zmin,zmax ; CALL flush(numout) 763 !p_fld = p_fld * p_mask 764 !zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld)*tmask",zmin,zmax ; CALL flush(numout) 765 766 zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"p_fld_crs",zmin,zmax; CALL flush(numout) 767 !p_fld_crs=10**(p_fld_crs*p_mask_crs) 768 !zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld_crs)",zmin,zmax; CALL flush(numout) 769 !p_fld_crs=p_fld_crs*p_mask_crs 770 !zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld_crs)*tmask",zmin,zmax; CALL flush(numout) 771 772 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp ) 773 CASE ( 'MED' ) 774 775 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 776 777 SELECT CASE ( cd_type ) 778 779 CASE( 'T', 'W' ) 780 DO jk = 1, jpk 781 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 782 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 783 ENDDO 784 785 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 786 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 787 je_2 = mje_crs(2) 788 DO jk = 1, jpk 789 DO ji = nistr, niend, nn_factx 790 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 791 792 ztmp1(:) = 0._wp 793 ztmp1(1:3) = p_fld(ji:ji+2,je_2,jk) 794 CALL PIKSRT(nn_factx*nn_facty,ztmp1) 795 ir=0 796 jr=1 797 DO WHILE( jr .LE. nn_factx*nn_facty ) 798 IF( ztmp1(jr) == 0. )THEN 799 ir=jr 800 jr=jr+1 801 ELSE 802 EXIT 803 ENDIF 804 ENDDO 805 IF( ir .LE. nn_factx*nn_facty-1 )THEN 806 ALLOCATE( ztmp2(nn_factx*nn_facty-ir) ) 807 ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty) 808 jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1 809 p_fld_crs(ii,2,jk) = ztmp2(jr) 810 DEALLOCATE( ztmp2 ) 811 ELSE 812 p_fld_crs(ii,ij,jk) = 0._wp 813 ENDIF 814 815 ENDDO 816 ENDDO 817 ENDIF 818 ELSE 819 je_2 = mjs_crs(2) 820 DO jk = 1, jpk 821 DO ji = nistr, niend, nn_factx 822 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 823 824 ztmp(:,:)= p_fld(ji:ji+2,je_2:je_2+2,jk) 825 zdim1(1)=nn_factx*nn_facty 529 DO jj = nldj_crs,nlej_crs 530 ijjs = mjs_crs(jj) 531 ijje = mje_crs(jj) 532 DO ji = nldi_crs, nlei_crs 533 ijis = mis_crs(ji) 534 ijie = mie_crs(ji) 535 536 ztmp(:,:)= p_fld(ijis:ijie,ijjs:ijje,jk) 537 zdim1(1) = nn_factx*nn_facty 826 538 ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 ) 827 539 CALL PIKSRT(nn_factx*nn_facty,ztmp1) 540 828 541 ir=0 829 542 jr=1 … … 840 553 ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty) 841 554 jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1 842 p_fld_crs( ii,2,jk) = ztmp2(jr)555 p_fld_crs(ji,jj,jk) = ztmp2(jr) 843 556 DEALLOCATE( ztmp2 ) 844 557 ELSE 845 p_fld_crs(ii,ij,jk) = 0._wp558 p_fld_crs(ji,jj,jk) = 0._wp 846 559 ENDIF 847 560 848 561 ENDDO 849 562 ENDDO 850 ENDIF851 !852 DO jk = 1, jpk853 DO jj = njstr, njend, nn_facty854 DO ji = nistr, niend, nn_factx855 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid856 ij = ( jj - njstr ) * rfacty_r + 3857 858 ztmp(:,:)= p_fld(ji:ji+2,jj:jj+2,jk)859 zdim1(1)=nn_factx*nn_facty860 ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 )861 CALL PIKSRT(nn_factx*nn_facty,ztmp1)862 ir=0863 jr=1864 DO WHILE( jr .LE. nn_factx*nn_facty )865 IF( ztmp1(jr) == 0. ) THEN866 ir=jr867 jr=jr+1868 ELSE869 EXIT870 ENDIF871 ENDDO872 IF( ir .LE. nn_factx*nn_facty-1 )THEN873 ALLOCATE( ztmp2(nn_factx*nn_facty-ir) )874 ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty)875 jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1876 p_fld_crs(ii,ij,jk) = ztmp2(jr)877 DEALLOCATE( ztmp2 )878 ELSE879 p_fld_crs(ii,ij,jk) = 0._wp880 ENDIF881 882 ENDDO883 ENDDO884 563 ENDDO 885 564 CASE DEFAULT 886 565 STOP 887 888 889 566 END SELECT 567 568 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 890 569 891 570 CASE ( 'SUM' ) … … 893 572 CALL wrk_alloc( jpi, jpj, jpk, zsurfmsk ) 894 573 895 SELECT CASE ( cd_type ) 896 CASE( 'W' ) 897 IF( PRESENT( p_e3 ) ) THEN 898 !cbr ????????????? 899 !zsurfmsk(:,:,1) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 900 !DO jk = 2, jpk 901 ! zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) 902 !ENDDO 903 DO jk = 1, jpk 904 zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 905 ENDDO 906 ELSE 907 !zsurfmsk(:,:,1) = p_e12(:,:) * p_mask(:,:,1) 908 !DO jk = 2, jpk 909 ! zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk-1) 910 !ENDDO 911 DO jk = 1, jpk 912 zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk) 913 ENDDO 914 ENDIF 915 CASE DEFAULT 916 IF( PRESENT( p_e3 ) ) THEN 917 DO jk = 1, jpk 918 zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 919 ENDDO 920 ELSE 921 DO jk = 1, jpk 922 zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk) 923 ENDDO 924 ENDIF 925 END SELECT 574 IF( PRESENT( p_e3 ) ) THEN 575 DO jk = 1, jpk 576 zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 577 ENDDO 578 ELSE 579 DO jk = 1, jpk 580 zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk) 581 ENDDO 582 ENDIF 926 583 927 584 SELECT CASE ( cd_type ) 928 585 929 586 CASE( 'T', 'W' ) 930 931 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 932 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 933 je_2 = mje_crs(2) 934 DO jk = 1, jpk 935 DO ji = nistr, niend, nn_factx 936 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 937 zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & 938 & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & 939 & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 940 ! 941 p_fld_crs(ii,2,jk) = zflcrs 942 ENDDO 943 ENDDO 944 ENDIF 945 ELSE 946 je_2 = mjs_crs(2) 947 DO jk = 1, jpk 948 DO ji = nistr, niend, nn_factx 949 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 950 zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & 951 & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & 952 & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & 953 & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & 954 & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 955 & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 956 & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & 957 & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 958 & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 959 ! 960 p_fld_crs(ii,2,jk) = zflcrs 587 588 DO jk = 1, jpk 589 DO jj = nldj_crs,nlej_crs 590 ijjs = mjs_crs(jj) 591 ijje = mje_crs(jj) 592 DO ji = nldi_crs, nlei_crs 593 ijis = mis_crs(ji) 594 ijie = mie_crs(ji) 595 596 p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 961 597 ENDDO 962 598 ENDDO 963 ENDIF 964 ! 965 DO jk = 1, jpk 966 DO jj = njstr, njend, nn_facty 967 DO ji = nistr, niend, nn_factx 968 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 969 ij = ( jj - njstr ) * rfacty_r + 3 970 zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & 971 & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & 972 & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & 973 & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & 974 & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 975 & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 976 & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & 977 & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 978 & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 979 ! 980 p_fld_crs(ii,ij,jk) = zflcrs 981 ! 982 ENDDO 983 ENDDO 984 ENDDO 985 599 ENDDO 600 986 601 CASE( 'V' ) 987 602 603 988 604 DO jk = 1, jpk 989 DO ji = nistr, niend, nn_factx 990 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 991 IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN !!cc bande du sud style ORCA2 992 IF( mje_crs(2) - mjs_crs(2) == 1 )THEN 993 jj = mje_crs(2) 994 zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & 995 & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & 996 & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) 997 998 !zsfcrs = zsurfmsk(ji ,jj ,jk) & 999 ! & + zsurfmsk(ji+1,jj ,jk) & 1000 ! & + zsurfmsk(ji+2,jj ,jk) 1001 1002 !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs 1003 !ELSE ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 1004 !ENDIF 1005 ENDIF 1006 ELSE 1007 ijje = mje_crs(2) 1008 zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & 1009 & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & 1010 & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 1011 ! 1012 !zsfcrs = zsurfmsk(ji ,ijje,jk) & 1013 ! & + zsurfmsk(ji+1,ijje,jk) & 1014 ! & + zsurfmsk(ji+2,ijje,jk) 1015 1016 p_fld_crs(ii,2,jk) = zflcrs 1017 !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs 1018 !ELSE ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 1019 !ENDIF 1020 1021 ENDIF 1022 1023 DO jj = njstr, njend, nn_facty 1024 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1025 ij = ( jj - njstr ) * rfacty_r + 3 1026 ijje = mje_crs(ij) 1027 ijie = mie_crs(ii) 1028 ! 1029 zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & 1030 & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & 1031 & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 1032 ! 1033 !zsfcrs = zsurfmsk(ji ,ijje,jk) & 1034 ! & + zsurfmsk(ji+1,ijje,jk) & 1035 ! & + zsurfmsk(ji+2,ijje,jk) 1036 1037 p_fld_crs(ii,ij,jk) = zflcrs 1038 !cbr1 1039 !iji=117 ; ijj=210 1040 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 1041 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 1042 !WRITE(narea+5000,*)"OPE V =======> " 1043 !WRITE(narea+5000,*)ii,ij,jk 1044 !WRITE(narea+5000,*)ji,jj,ijje 1045 !WRITE(narea+5000,*)p_fld(ji ,ijje,jk) 1046 !WRITE(narea+5000,*)p_fld(ji+1,ijje,jk) 1047 !WRITE(narea+5000,*)p_fld(ji+2,ijje,jk) 1048 !WRITE(narea+5000,*)zflcrs 1049 !ENDIF 1050 1051 !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,ij,jk) = zflcrs 1052 !ELSE ; p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 1053 !ENDIF 1054 ! 1055 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )WRITE(narea+5000,*)" p_fld_crs(ii,ij,jk) = ", p_fld_crs(ii,ij,jk) 605 DO jj = nldj_crs,nlej_crs 606 ijjs = mjs_crs(jj) 607 ijje = mje_crs(jj) 608 DO ji = nldi_crs, nlei_crs 609 ijis = mis_crs(ji) 610 ijie = mie_crs(ji) 611 612 p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijje,jk) * zsurfmsk(ijis:ijie,ijje,jk) ) 1056 613 ENDDO 1057 614 ENDDO 1058 615 ENDDO 1059 616 1060 617 CASE( 'U' ) 1061 618 1062 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1063 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1064 je_2 = mje_crs(2) 1065 DO jk = 1, jpk 1066 DO ji = nistr, niend, nn_factx 1067 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1068 ijie = mie_crs(ii) 1069 zflcrs = p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk) 1070 p_fld_crs(ii,2,jk) = zflcrs 1071 ENDDO 1072 ENDDO 1073 ENDIF 1074 ELSE 1075 je_2 = mjs_crs(2) 1076 DO jk = 1, jpk 1077 DO ji = nistr, niend, nn_factx 1078 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1079 ijie = mie_crs(ii) 1080 zflcrs = p_fld(ijie,je_2 ,jk) * zsurfmsk(ijie,je_2 ,jk) & 1081 & + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk) & 1082 & + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk) 1083 1084 p_fld_crs(ii,2,jk) = zflcrs 619 DO jk = 1, jpk 620 DO jj = nldj_crs,nlej_crs 621 ijjs = mjs_crs(jj) 622 ijje = mje_crs(jj) 623 DO ji = nldi_crs, nlei_crs 624 ijis = mis_crs(ji) 625 ijie = mie_crs(ji) 626 627 p_fld_crs(ji,jj,jk) = SUM( p_fld(ijie,ijjs:ijje,jk) * zsurfmsk(ijie,ijjs:ijje,jk) ) 1085 628 ENDDO 1086 629 ENDDO 1087 ENDIF 1088 ! 1089 DO jk = 1, jpk 1090 DO jj = njstr, njend, nn_facty 1091 DO ji = nistr, niend, nn_factx 1092 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1093 ij = ( jj - njstr ) * rfacty_r + 3 1094 ijie = mie_crs(ii) 1095 zflcrs = p_fld(ijie,jj ,jk) * zsurfmsk(ijie,jj ,jk) & 1096 & + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk) & 1097 & + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk) 1098 ! 1099 p_fld_crs(ii,ij,jk) = zflcrs 1100 ! 1101 ENDDO 1102 ENDDO 1103 ENDDO 630 ENDDO 1104 631 1105 632 END SELECT … … 1109 636 ENDIF 1110 637 1111 !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) end SUM = ",p_fld(17,5,74)1112 638 CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk ) 1113 639 … … 1116 642 CALL wrk_alloc( jpi, jpj, jpk, zmask ) 1117 643 1118 SELECT CASE ( cd_type ) 1119 CASE( 'W' ) 1120 zmask(:,:,1) = p_mask(:,:,1) 1121 DO jk = 2, jpk 1122 zmask(:,:,jk) = p_mask(:,:,jk-1) 1123 ENDDO 1124 CASE ( 'T' ) 1125 DO jk = 1, jpk 1126 zmask(:,:,jk) = p_mask(:,:,jk) 1127 ENDDO 1128 END SELECT 644 DO jk = 1, jpk 645 zmask(:,:,jk) = p_mask(:,:,jk) 646 ENDDO 1129 647 1130 648 SELECT CASE ( cd_type ) 1131 649 1132 650 CASE( 'T', 'W' ) 1133 1134 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1135 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1136 je_2 = mje_crs(2) 1137 DO jk = 1, jpk 1138 DO ji = nistr, niend, nn_factx 1139 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1140 zflcrs = & 1141 & MAX( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) - ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & 1142 & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & 1143 & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) 1144 ! 1145 p_fld_crs(ii,2,jk) = zflcrs 1146 ENDDO 1147 ENDDO 1148 ENDIF 1149 ELSE 1150 je_2 = mjs_crs(2) 1151 DO jk = 1, jpk 1152 DO ji = nistr, niend, nn_factx 1153 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1154 zflcrs = & 1155 & MAX( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) - ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & 1156 & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) - ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & 1157 & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) - ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & 1158 & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) - ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & 1159 & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) - ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & 1160 & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) - ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & 1161 & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) - ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & 1162 & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) - ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & 1163 & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) - ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) 1164 ! 1165 p_fld_crs(ii,2,jk) = zflcrs 651 652 DO jk = 1, jpk 653 DO jj = nldj_crs,nlej_crs 654 ijjs = mjs_crs(jj) 655 ijje = mje_crs(jj) 656 DO ji = nldi_crs, nlei_crs 657 ijis = mis_crs(ji) 658 ijie = mie_crs(ji) 659 p_fld_crs(ji,jj,jk) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) - & 660 & ( ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk))* r_inf ) ) 1166 661 ENDDO 1167 662 ENDDO 1168 ENDIF 1169 ! 1170 DO jk = 1, jpk 1171 DO jj = njstr, njend, nn_facty 1172 DO ji = nistr, niend, nn_factx 1173 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1174 ij = ( jj - njstr ) * rfacty_r + 3 1175 zflcrs = & 1176 & MAX( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) - ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & 1177 & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) - ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & 1178 & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) - ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & 1179 & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) - ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & 1180 & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & 1181 & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & 1182 & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) - ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & 1183 & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & 1184 & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) 1185 ! 1186 p_fld_crs(ii,ij,jk) = zflcrs 1187 ! 1188 ENDDO 1189 ENDDO 1190 ENDDO 1191 663 ENDDO 664 1192 665 CASE( 'V' ) 1193 1194 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21195 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1196 ! ijje = mje_crs(2)1197 ! ENDIF1198 ! ELSE1199 ! ijje = mjs_crs(2)1200 ! ENDIF1201 !1202 ! DO jk = 1, jpk1203 ! DO ji = nistr, niend, nn_factx1204 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21205 ! zflcrs = &1206 ! & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1207 ! & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1208 ! & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )1209 ! !1210 ! p_fld_crs(ii,2,jk) = zflcrs1211 ! ENDDO1212 ! ENDDO1213 ! !1214 ! DO jk = 1, jpk1215 ! DO jj = njstr, njend, nn_facty1216 ! DO ji = nistr, niend, nn_factx1217 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid1218 ! ij = ( jj - njstr ) * rfacty_r + 31219 ! ijje = mje_crs(ij)1220 ! !1221 ! zflcrs = &1222 ! & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1223 ! & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1224 ! & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )1225 ! !1226 ! p_fld_crs(ii,ij,jk) = zflcrs1227 ! !1228 ! ENDDO1229 ! ENDDO1230 ! ENDDO1231 666 CALL ctl_stop('MAX operator and V case not available') 1232 667 1233 668 CASE( 'U' ) 1234 1235 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21236 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1237 ! je_2 = mje_crs(2)1238 ! DO jk = 1, jpk1239 ! DO ji = nistr, niend, nn_factx1240 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21241 ! ijie = mie_crs(ii)1242 ! zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf1243 ! !1244 ! p_fld_crs(ii,2,jk) = zflcrs1245 ! ENDDO1246 ! ENDDO1247 ! ENDIF1248 ! ELSE1249 ! je_2 = mjs_crs(2)1250 ! DO jk = 1, jpk1251 ! DO ji = nistr, niend, nn_factx1252 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21253 ! ijie = mie_crs(ii)1254 ! zflcrs = &1255 ! & MAX( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , &1256 ! & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , &1257 ! & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf )1258 ! !1259 ! p_fld_crs(ii,2,jk) = zflcrs1260 ! ENDDO1261 ! ENDDO1262 ! ENDIF1263 ! !1264 ! DO jk = 1, jpk1265 ! DO jj = njstr, njend, nn_facty1266 ! DO ji = nistr, niend, nn_factx1267 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21268 ! ij = ( jj - njstr ) * rfacty_r + 31269 ! ijie = mie_crs(ii)1270 ! zflcrs = &1271 ! & MAX( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , &1272 ! & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , &1273 ! & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf )1274 ! !1275 ! p_fld_crs(ii,ij,jk) = zflcrs1276 ! !1277 ! ENDDO1278 ! ENDDO1279 ! ENDDO1280 669 CALL ctl_stop('MAX operator and U case not available') 1281 670 1282 1283 1284 671 END SELECT 672 673 CALL wrk_dealloc( jpi, jpj, jpk, zmask ) 1285 674 1286 675 CASE ( 'MIN' ) ! Search the min of unmasked grid cells 1287 676 1288 677 CALL wrk_alloc( jpi, jpj, jpk, zmask ) 1289 1290 !SELECT CASE ( cd_type ) 1291 ! CASE( 'W' ) 1292 ! !cbr ????????????????????????????? 1293 ! zmask(:,:,1) = p_mask(:,:,1) 1294 ! DO jk = 2, jpk 1295 ! zmask(:,:,jk) = p_mask(:,:,jk-1) 1296 ! ENDDO 1297 ! CASE ( 'T' ) 678 DO jk = 1, jpk 679 zmask(:,:,jk) = p_mask(:,:,jk) 680 ENDDO 681 682 SELECT CASE ( cd_type ) 683 684 CASE( 'T', 'W' ) 685 1298 686 DO jk = 1, jpk 1299 zmask(:,:,jk) = p_mask(:,:,jk) 1300 ENDDO 1301 !END SELECT 1302 1303 SELECT CASE ( cd_type ) 1304 1305 CASE( 'T', 'W' ) 1306 1307 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1308 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1309 je_2 = mje_crs(2) 1310 DO jk = 1, jpk 1311 DO ji = nistr, niend, nn_factx 1312 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1313 zflcrs = & 1314 & MIN( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) + ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & 1315 & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & 1316 & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) 1317 ! 1318 p_fld_crs(ii,2,jk) = zflcrs 1319 ENDDO 1320 ENDDO 1321 ENDIF 1322 ELSE 1323 je_2 = mjs_crs(2) 1324 DO jk = 1, jpk 1325 DO ji = nistr, niend, nn_factx 1326 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1327 zflcrs = & 1328 & MIN( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) + ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & 1329 & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) + ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & 1330 & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) + ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & 1331 & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) + ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & 1332 & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) + ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & 1333 & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) + ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & 1334 & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) + ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & 1335 & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) + ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & 1336 & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) 1337 ! 1338 p_fld_crs(ii,2,jk) = zflcrs 687 DO jj = nldj_crs,nlej_crs 688 ijjs = mjs_crs(jj) 689 ijje = mje_crs(jj) 690 DO ji = nldi_crs, nlei_crs 691 ijis = mis_crs(ji) 692 ijie = mie_crs(ji) 693 694 p_fld_crs(ji,jj,jk) = MINVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) + & 695 & ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk)* r_inf ) ) 1339 696 ENDDO 1340 697 ENDDO 1341 ENDIF 1342 ! 1343 DO jk = 1, jpk 1344 DO jj = njstr, njend, nn_facty 1345 DO ji = nistr, niend, nn_factx 1346 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1347 ij = ( jj - njstr ) * rfacty_r + 3 1348 zflcrs = & 1349 & MIN( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) + ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & 1350 & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) + ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & 1351 & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) + ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & 1352 & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) + ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & 1353 & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & 1354 & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & 1355 & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) + ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & 1356 & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & 1357 & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) 1358 ! 1359 p_fld_crs(ii,ij,jk) = zflcrs 1360 ! 1361 ENDDO 1362 ENDDO 1363 ENDDO 698 ENDDO 699 1364 700 1365 701 CASE( 'V' ) 1366 1367 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21368 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1369 ! ijje = mje_crs(2)1370 ! ENDIF1371 ! ELSE1372 ! ijje = mjs_crs(2)1373 ! ENDIF1374 !1375 ! DO jk = 1, jpk1376 ! DO ji = nistr, niend, nn_factx1377 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21378 ! zflcrs = &1379 ! & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1380 ! & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1381 ! & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )1382 ! !1383 ! p_fld_crs(ii,2,jk) = zflcrs1384 ! ENDDO1385 ! ENDDO1386 ! !1387 ! DO jk = 1, jpk1388 ! DO jj = njstr, njend, nn_facty1389 ! DO ji = nistr, niend, nn_factx1390 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid1391 ! ij = ( jj - njstr ) * rfacty_r + 31392 ! ijje = mje_crs(ij)1393 ! zflcrs = &1394 ! & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1395 ! & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , &1396 ! & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )1397 ! !1398 ! p_fld_crs(ii,ij,jk) = zflcrs1399 ! !1400 ! ENDDO1401 ! ENDDO1402 ! ENDDO1403 702 CALL ctl_stop('MIN operator and V case not available') 1404 1405 703 1406 704 CASE( 'U' ) 1407 1408 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21409 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1410 ! je_2 = mje_crs(2)1411 ! DO jk = 1, jpk1412 ! DO ji = nistr, niend, nn_factx1413 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21414 ! ijie = mie_crs(ii)1415 ! zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf1416 ! !1417 ! p_fld_crs(ii,2,jk) = zflcrs1418 ! ENDDO1419 ! ENDDO1420 ! ENDIF1421 ! ELSE1422 ! je_2 = mjs_crs(2)1423 ! DO jk = 1, jpk1424 ! DO ji = nistr, niend, nn_factx1425 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21426 ! ijie = mie_crs(ii)1427 ! zflcrs = &1428 ! & MIN( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , &1429 ! & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , &1430 ! & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf )1431 ! !1432 ! p_fld_crs(ii,2,jk) = zflcrs1433 ! ENDDO1434 ! ENDDO1435 ! ENDIF1436 ! !1437 ! DO jk = 1, jpk1438 ! DO jj = njstr, njend, nn_facty1439 ! DO ji = nistr, niend, nn_factx1440 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21441 ! ij = ( jj - njstr ) * rfacty_r + 31442 ! ijie = mie_crs(ii)1443 ! zflcrs = &1444 ! & MIN( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , &1445 ! & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , &1446 ! & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf )1447 ! !1448 ! p_fld_crs(ii,ij,jk) = zflcrs1449 ! !1450 ! ENDDO1451 ! ENDDO1452 ! ENDDO1453 705 CALL ctl_stop('MIN operator and U case not available') 1454 706 … … 1459 711 END SELECT 1460 712 ! 1461 !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) avt lbc = ",p_fld(17,5,74)1462 713 CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) 1463 !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) apr lbc = ",p_fld(17,5,74)1464 714 ! 1465 715 END SUBROUTINE crs_dom_ope_3d … … 1504 754 !! Local variables 1505 755 INTEGER :: ji, jj, jk ! dummy loop indices 1506 INTEGER :: ijie, ijje, ii, ij, je_2756 INTEGER :: ijis, ijie, ijjs, ijje 1507 757 REAL(wp) :: zflcrs, zsfcrs 1508 758 REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk … … 1515 765 1516 766 CASE ( 'VOL' ) 1517 767 1518 768 CALL wrk_alloc( jpi, jpj, zsurfmsk ) 1519 769 zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 1520 770 1521 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1522 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1523 je_2 = mje_crs(2) 1524 DO ji = nistr, niend, nn_factx 1525 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1526 zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & 1527 & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & 1528 & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 1529 1530 zsfcrs = zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2) 1531 ! 1532 p_fld_crs(ii,2) = zflcrs 1533 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs 1534 ENDDO 1535 ENDIF 1536 ELSE 1537 je_2 = mjs_crs(2) 1538 DO ji = nistr, niend, nn_factx 1539 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1540 zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & 1541 & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & 1542 & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & 1543 & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & 1544 & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & 1545 & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & 1546 & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & 1547 & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & 1548 & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 1549 1550 zsfcrs = zsurfmsk(ji,je_2 ) + zsurfmsk(ji+1,je_2 ) + zsurfmsk(ji+2,je_2 ) & 1551 & + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) & 1552 & + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2) 1553 ! 1554 p_fld_crs(ii,2) = zflcrs 1555 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs 1556 ENDDO 1557 ENDIF 1558 ! 1559 DO jj = njstr, njend, nn_facty 1560 DO ji = nistr, niend, nn_factx 1561 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1562 ij = ( jj - njstr ) * rfacty_r + 3 1563 zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & 1564 & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & 1565 & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & 1566 & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & 1567 & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & 1568 & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & 1569 & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & 1570 & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & 1571 & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 1572 1573 zsfcrs = zsurfmsk(ji,jj ) + zsurfmsk(ji+1,jj ) + zsurfmsk(ji+2,jj ) & 1574 & + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) & 1575 & + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2) 1576 ! 1577 p_fld_crs(ii,ij) = zflcrs 1578 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij) = zflcrs / zsfcrs 1579 ENDDO 1580 ENDDO 1581 771 DO jj = nldj_crs,nlej_crs 772 ijjs = mjs_crs(jj) 773 ijje = mje_crs(jj) 774 DO ji = nldi_crs, nlei_crs 775 ijis = mis_crs(ji) 776 ijie = mie_crs(ji) 777 778 zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) ) 779 zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje) ) 780 781 p_fld_crs(ji,jj) = zflcrs 782 IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj) = zflcrs / zsfcrs 783 ENDDO 784 ENDDO 1582 785 CALL wrk_dealloc( jpi, jpj, zsurfmsk ) 786 ! 1583 787 1584 788 CASE ( 'SUM' ) … … 1595 799 CASE( 'T', 'W' ) 1596 800 1597 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1598 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1599 je_2 = mje_crs(2) 1600 DO ji = nistr, niend, nn_factx 1601 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1602 zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & 1603 & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & 1604 & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 1605 ! 1606 p_fld_crs(ii,2) = zflcrs 1607 ENDDO 1608 ENDIF 1609 ELSE 1610 je_2 = mjs_crs(2) 1611 DO ji = nistr, niend, nn_factx 1612 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1613 zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & 1614 & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & 1615 & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & 1616 & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & 1617 & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & 1618 & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & 1619 & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & 1620 & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & 1621 & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 1622 ! 1623 p_fld_crs(ii,2) = zflcrs 1624 ENDDO 1625 ENDIF 1626 ! 1627 DO jj = njstr, njend, nn_facty 1628 DO ji = nistr, niend, nn_factx 1629 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1630 ij = ( jj - njstr ) * rfacty_r + 3 1631 zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & 1632 & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & 1633 & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & 1634 & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & 1635 & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & 1636 & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & 1637 & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & 1638 & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & 1639 & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 1640 ! 1641 p_fld_crs(ii,ij) = zflcrs 1642 ! 1643 ENDDO 1644 ENDDO 801 DO jj = nldj_crs,nlej_crs 802 ijjs = mjs_crs(jj) 803 ijje = mje_crs(jj) 804 DO ji = nldi_crs, nlei_crs 805 ijis = mis_crs(ji) 806 ijie = mie_crs(ji) 807 p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) ) 808 ENDDO 809 ENDDO 1645 810 1646 811 CASE( 'V' ) 1647 DO ji = nistr, niend, nn_factx 1648 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1649 IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN !!cc bande du sud style ORCA2 1650 IF( mje_crs(2) - mjs_crs(2) == 1 )THEN 1651 jj = mje_crs(2) 1652 zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & 1653 & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & 1654 & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) 1655 p_fld_crs(ii,2) = zflcrs 1656 ENDIF 1657 ELSE 1658 ijje = mje_crs(2) 1659 zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & 1660 & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & 1661 & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 1662 ! 1663 p_fld_crs(ii,2) = zflcrs 1664 ENDIF 1665 1666 DO jj = njstr, njend, nn_facty 1667 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1668 ij = ( jj - njstr ) * rfacty_r + 3 1669 ijje = mje_crs(ij) 1670 ijie = mie_crs(ii) 1671 ! 1672 zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & 1673 & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & 1674 & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 1675 ! 1676 p_fld_crs(ii,ij) = zflcrs 1677 ! 1678 ENDDO 1679 ENDDO 1680 812 813 DO jj = nldj_crs,nlej_crs 814 ijjs = mjs_crs(jj) 815 ijje = mje_crs(jj) 816 DO ji = nldi_crs, nlei_crs 817 ijis = mis_crs(ji) 818 ijie = mie_crs(ji) 819 p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijje) * zsurfmsk(ijis:ijie,ijje) ) 820 ENDDO 821 ENDDO 822 1681 823 CASE( 'U' ) 1682 824 1683 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1684 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1685 je_2 = mje_crs(2) 1686 DO ji = nistr, niend, nn_factx 1687 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1688 ijie = mie_crs(ii) 1689 zflcrs = p_fld(ijie,je_2) * zsurfmsk(ijie,je_2) 1690 p_fld_crs(ii,2) = zflcrs 1691 ENDDO 1692 ENDIF 1693 ELSE 1694 je_2 = mjs_crs(2) 1695 DO ji = nistr, niend, nn_factx 1696 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1697 ijie = mie_crs(ii) 1698 zflcrs = p_fld(ijie,je_2 ) * zsurfmsk(ijie,je_2 ) & 1699 & + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1) & 1700 & + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2) 1701 1702 p_fld_crs(ii,2) = zflcrs 825 DO jj = nldj_crs,nlej_crs 826 ijjs = mjs_crs(jj) 827 ijje = mje_crs(jj) 828 DO ji = nldi_crs, nlei_crs 829 ijis = mis_crs(ji) 830 ijie = mie_crs(ji) 831 p_fld_crs(ji,jj) = SUM( p_fld(ijie,ijjs:ijje) * zsurfmsk(ijie,ijjs:ijje) ) 1703 832 ENDDO 1704 ENDIF 1705 1706 DO jj = njstr, njend, nn_facty 1707 DO ji = nistr, niend, nn_factx 1708 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1709 ij = ( jj - njstr ) * rfacty_r + 3 1710 ijie = mie_crs(ii) 1711 zflcrs = p_fld(ijie,jj ) * zsurfmsk(ijie,jj ) & 1712 & + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1) & 1713 & + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2) 1714 ! 1715 p_fld_crs(ii,ij) = zflcrs 1716 ! 1717 ENDDO 1718 ENDDO 833 ENDDO 1719 834 1720 835 END SELECT … … 1731 846 1732 847 CASE( 'T', 'W' ) 1733 1734 DO ji = nistr, niend, nn_factx 1735 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1736 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1737 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1738 je_2 = mje_crs(2) 1739 zflcrs = & 1740 & MAX( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) - ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & 1741 & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & 1742 & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) 1743 ! 1744 p_fld_crs(ii,2) = zflcrs 1745 ENDIF 1746 ELSE 1747 je_2 = mjs_crs(2) 1748 zflcrs = & 1749 & MAX( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) - ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & 1750 & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) - ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & 1751 & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) - ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & 1752 & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) - ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & 1753 & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) - ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & 1754 & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) - ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & 1755 & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) - ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & 1756 & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) - ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & 1757 & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) - ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) 1758 ! 1759 p_fld_crs(ii,2) = zflcrs 1760 ENDIF 1761 1762 DO jj = njstr, njend, nn_facty 1763 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1764 ij = ( jj - njstr ) * rfacty_r + 3 1765 zflcrs = & 1766 & MAX( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) - ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & 1767 & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) - ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & 1768 & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) - ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & 1769 & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) - ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & 1770 & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & 1771 & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & 1772 & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) - ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & 1773 & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & 1774 & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) 1775 ! 1776 p_fld_crs(ii,ij) = zflcrs 1777 ! 1778 ENDDO 1779 ENDDO 848 849 DO jj = nldj_crs,nlej_crs 850 ijjs = mjs_crs(jj) 851 ijje = mje_crs(jj) 852 DO ji = nldi_crs, nlei_crs 853 ijis = mis_crs(ji) 854 ijie = mie_crs(ji) 855 p_fld_crs(ji,jj) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) - & 856 & ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) ) ) 857 ENDDO 858 ENDDO 1780 859 1781 860 CASE( 'V' ) 1782 1783 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21784 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1785 ! ijje = mje_crs(2)1786 ! ENDIF1787 ! ELSE1788 ! ijje = mjs_crs(2)1789 ! ENDIF1790 !1791 ! DO ji = nistr, niend, nn_factx1792 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21793 ! zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1794 ! & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1795 ! & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )1796 ! !1797 ! p_fld_crs(ii,2) = zflcrs1798 ! ENDDO1799 ! DO jj = njstr, njend, nn_facty1800 ! DO ji = nistr, niend, nn_factx1801 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21802 ! ij = ( jj - njstr ) * rfacty_r + 31803 ! ijje = mje_crs(ij)1804 ! !1805 ! zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1806 ! & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1807 ! & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )1808 ! !1809 ! p_fld_crs(ii,ij) = zflcrs1810 ! !1811 ! ENDDO1812 ! ENDDO1813 861 CALL ctl_stop('MAX operator and V case not available') 1814 862 1815 863 CASE( 'U' ) 1816 1817 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21818 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1819 ! je_2 = mje_crs(2)1820 ! DO ji = nistr, niend, nn_factx1821 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21822 ! ijie = mie_crs(ii)1823 ! zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf1824 ! p_fld_crs(ii,2) = zflcrs1825 ! ENDDO1826 ! ENDIF1827 ! ELSE1828 ! je_2 = mjs_crs(2)1829 ! DO ji = nistr, niend, nn_factx1830 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21831 ! ijie = mie_crs(ii)1832 ! zflcrs = &1833 ! & MAX( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , &1834 ! & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , &1835 ! & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf )1836 ! p_fld_crs(ii,2) = zflcrs1837 ! ENDDO1838 ! ENDIF1839 ! DO jj = njstr, njend, nn_facty1840 ! DO ji = nistr, niend, nn_factx1841 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21842 ! ij = ( jj - njstr ) * rfacty_r + 31843 ! ijie = mie_crs(ii)1844 ! zflcrs = &1845 ! & MAX( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , &1846 ! & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , &1847 ! & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf )1848 ! p_fld_crs(ii,ij) = zflcrs1849 ! !1850 ! ENDDO1851 ! ENDDO1852 864 CALL ctl_stop('MAX operator and U case not available') 1853 865 … … 1859 871 1860 872 CASE( 'T', 'W' ) 1861 1862 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1863 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1864 je_2 = mje_crs(2) 1865 DO ji = nistr, niend, nn_factx 1866 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1867 zflcrs = & 1868 & MIN( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) + ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & 1869 & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & 1870 & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) 1871 ! 1872 p_fld_crs(ii,2) = zflcrs 1873 ENDDO 1874 ENDIF 1875 ELSE 1876 DO ji = nistr, niend, nn_factx 1877 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1878 je_2 = mjs_crs(2) 1879 zflcrs = & 1880 & MIN( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) + ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & 1881 & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) + ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & 1882 & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) + ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & 1883 & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) + ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & 1884 & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) + ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & 1885 & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) + ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & 1886 & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) + ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & 1887 & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) + ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & 1888 & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) + ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) 1889 ! 1890 p_fld_crs(ii,2) = zflcrs 1891 ENDDO 1892 ENDIF 1893 1894 DO jj = njstr, njend, nn_facty 1895 DO ji = nistr, niend, nn_factx 1896 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1897 ij = ( jj - njstr ) * rfacty_r + 3 1898 zflcrs = & 1899 & MIN( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) + ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & 1900 & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) + ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & 1901 & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) + ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & 1902 & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) + ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & 1903 & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & 1904 & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & 1905 & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) + ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & 1906 & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & 1907 & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) 1908 ! 1909 p_fld_crs(ii,ij) = zflcrs 1910 ! 1911 ENDDO 1912 ENDDO 873 874 DO jj = nldj_crs,nlej_crs 875 ijjs = mjs_crs(jj) 876 ijje = mje_crs(jj) 877 DO ji = nldi_crs, nlei_crs 878 ijis = mis_crs(ji) 879 ijie = mie_crs(ji) 880 p_fld_crs(ji,jj) = MINVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) + & 881 & ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) ) ) 882 ENDDO 883 ENDDO 1913 884 1914 885 CASE( 'V' ) 1915 1916 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21917 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1918 ! ijje = mje_crs(2)1919 ! ENDIF1920 ! ELSE1921 ! ijje = mjs_crs(2)1922 ! ENDIF1923 !1924 ! DO ji = nistr, niend, nn_factx1925 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21926 ! zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1927 ! & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1928 ! & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )1929 ! !1930 ! p_fld_crs(ii,2) = zflcrs1931 ! ENDDO1932 ! DO jj = njstr, njend, nn_facty1933 ! DO ji = nistr, niend, nn_factx1934 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21935 ! ij = ( jj - njstr ) * rfacty_r + 31936 ! ijje = mje_crs(ij)1937 ! !1938 ! zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1939 ! & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , &1940 ! & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )1941 ! !1942 ! p_fld_crs(ii,ij) = zflcrs1943 ! !1944 ! ENDDO1945 ! ENDDO1946 886 CALL ctl_stop('MIN operator and V case not available') 1947 887 1948 888 CASE( 'U' ) 1949 1950 ! IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA21951 ! IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN1952 ! je_2 = mje_crs(2)1953 ! DO ji = nistr, niend, nn_factx1954 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21955 ! ijie = mie_crs(ii)1956 ! zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf1957 !1958 ! p_fld_crs(ii,2) = zflcrs1959 ! ENDDO1960 ! ENDIF1961 ! ELSE1962 ! je_2 = mjs_crs(2)1963 ! DO ji = nistr, niend, nn_factx1964 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21965 ! ijie = mie_crs(ii)1966 ! zflcrs = &1967 ! & MIN( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , &1968 ! & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , &1969 ! & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf )1970 ! p_fld_crs(ii,2) = zflcrs1971 ! ENDDO1972 ! ENDIF1973 ! DO jj = njstr, njend, nn_facty1974 ! DO ji = nistr, niend, nn_factx1975 ! ii = ( ji - mis_crs(2) ) * rfactx_r + 21976 ! ij = ( jj - njstr ) * rfacty_r + 31977 ! ijie = mie_crs(ii)1978 ! zflcrs = &1979 ! & MIN( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , &1980 ! & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , &1981 ! & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf )1982 ! p_fld_crs(ii,ij) = zflcrs1983 ! !1984 ! ENDDO1985 ! ENDDO1986 889 CALL ctl_stop('MIN operator and U case not available') 1987 890 … … 1994 897 END SUBROUTINE crs_dom_ope_2d 1995 898 1996 SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_ crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs)899 SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_2d_crs, p_sfc_3d_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs) 1997 900 !!---------------------------------------------------------------- 901 !! 902 !! 903 !! 904 !! 905 !!---------------------------------------------------------------- 1998 906 !! Arguments 1999 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) 2000 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask 2001 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid 2002 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid 2003 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity 2004 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity 2005 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity 907 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) 908 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask 909 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid 910 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid 911 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in),OPTIONAL :: p_sfc_2d_crs ! Coarse grid box east or north face quantity 912 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in),OPTIONAL :: p_sfc_3d_crs ! Coarse grid box east or north face quantity 913 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity 914 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity 2006 915 2007 916 !! Local variables 2008 917 INTEGER :: ji, jj, jk ! dummy loop indices 2009 INTEGER :: iji e, ijje, ii, ij, je_2918 INTEGER :: ijis, ijie, ijjs, ijje 2010 919 REAL(wp) :: ze3crs 2011 !REAL(wp), DIMENSION(:,:,:), POINTER :: zmask, zsurf2012 920 2013 921 !!---------------------------------------------------------------- 2014 2015 p_e3_crs (:,:,:) = 0. 2016 p_e3_max_crs(:,:,:) = 1. 922 p_e3_crs (:,:,:) = 0._wp 923 p_e3_max_crs(:,:,:) = 0._wp 2017 924 2018 925 2019 !CALL wrk_alloc( jpi, jpj, jpk, zmask, zsurf ) 2020 2021 SELECT CASE ( cd_type ) 926 SELECT CASE ( cd_type ) 2022 927 2023 928 CASE ('T') 2024 929 2025 DO jk = 1 , jpk 2026 DO ji = nistr, niend, nn_factx 2027 2028 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2029 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 2030 2031 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2032 2033 jj = mje_crs(2) 2034 2035 2036 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 2037 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 2038 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk)) 2039 2040 p_e3_max_crs(ii,2,jk) = ze3crs 2041 2042 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 2043 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 2044 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) 2045 2046 2047 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2048 ENDIF 2049 ELSE 2050 jj = mjs_crs(2) 2051 2052 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 2053 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 2054 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 2055 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk), & 2056 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk), & 2057 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 2058 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 2059 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 2060 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 2061 2062 p_e3_max_crs(ii,2,jk) = ze3crs 2063 2064 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 2065 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 2066 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 2067 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk) + & 2068 & p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk) + & 2069 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) + & 2070 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 2071 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) + & 2072 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 2073 2074 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2075 ENDIF 2076 2077 DO jj = njstr, njend, nn_facty 2078 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 2079 ij = ( jj - njstr ) * rfacty_r + 3 2080 ijje = mje_crs(ij) 2081 ijie = mie_crs(ii) 2082 ! 2083 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 2084 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 2085 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 2086 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk), & 2087 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk), & 2088 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 2089 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 2090 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 2091 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 2092 2093 p_e3_max_crs(ii,ij,jk) = ze3crs 2094 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 2095 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 2096 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 2097 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk) + & 2098 & p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk) + & 2099 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) + & 2100 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 2101 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) + & 2102 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 2103 2104 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 930 DO jk = 1, jpk 931 DO ji = nldi_crs, nlei_crs 932 933 ijis = mis_crs(ji) 934 ijie = mie_crs(ji) 935 936 DO jj = nldj_crs, nlej_crs 937 938 ijjs = mjs_crs(jj) 939 ijje = mje_crs(jj) 940 941 p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 942 943 ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 944 IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk) 2105 945 2106 946 ENDDO … … 2110 950 CASE ('U') 2111 951 2112 DO jk = 1 , jpk 2113 DO ji = nistr, niend, nn_factx 2114 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2115 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 2116 2117 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2118 2119 jj = mje_crs(2) 2120 2121 2122 ze3crs = p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk) 2123 2124 p_e3_max_crs(ii,2,jk) = ze3crs 2125 2126 ze3crs = p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) 2127 2128 2129 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2130 ENDIF 2131 ELSE 2132 jj = mjs_crs(2) 2133 2134 ze3crs = MAX( p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 2135 p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 2136 p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 2137 2138 p_e3_max_crs(ii,2,jk) = ze3crs 2139 2140 ze3crs = p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 2141 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) + & 2142 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 2143 2144 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2145 ENDIF 2146 DO jj = njstr, njend, nn_facty 2147 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 2148 ij = ( jj - njstr ) * rfacty_r + 3 2149 ijje = mje_crs(ij) 2150 ijie = mie_crs(ii) 2151 ! 2152 ze3crs = MAX( p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 2153 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 2154 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 2155 2156 p_e3_max_crs(ii,ij,jk) = ze3crs 2157 2158 ze3crs = p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 2159 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) + & 2160 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 2161 2162 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 2163 952 DO jk = 1, jpk 953 DO ji = nldi_crs, nlei_crs 954 955 ijis = mis_crs(ji) 956 ijie = mie_crs(ji) 957 958 DO jj = nldj_crs, nlej_crs 959 960 ijjs = mjs_crs(jj) 961 ijje = mje_crs(jj) 962 963 p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) ) 964 965 ze3crs = SUM( p_e2(ijie,ijjs:ijje) * p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) ) 966 IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj) 2164 967 ENDDO 2165 968 ENDDO … … 2167 970 2168 971 CASE ('V') 2169 DO jk = 1 , jpk 2170 DO ji = nistr, niend, nn_factx 2171 2172 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2173 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 2174 2175 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2176 2177 jj = mje_crs(2) 2178 2179 2180 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 2181 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 2182 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk)) 2183 2184 p_e3_max_crs(ii,2,jk) = ze3crs 2185 2186 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 2187 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 2188 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) 2189 2190 2191 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2192 ENDIF 2193 ELSE 2194 jj = mjs_crs(2) 2195 2196 ze3crs = MAX( p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 2197 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 2198 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 2199 2200 p_e3_max_crs(ii,2,jk) = ze3crs 2201 2202 ze3crs = p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 2203 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) + & 2204 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 2205 2206 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2207 ENDIF 2208 2209 DO jj = njstr, njend, nn_facty 2210 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 2211 ij = ( jj - njstr ) * rfacty_r + 3 2212 ijje = mje_crs(ij) 2213 ijie = mie_crs(ii) 2214 ! 2215 ze3crs = MAX( p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 2216 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 2217 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 2218 2219 p_e3_max_crs(ii,ij,jk) = ze3crs 2220 2221 ze3crs = p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 2222 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) + & 2223 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 2224 2225 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 972 973 DO jk = 1, jpk 974 DO ji = nldi_crs, nlei_crs 975 976 ijis = mis_crs(ji) 977 ijie = mie_crs(ji) 978 979 DO jj = nldj_crs, nlej_crs 980 981 ijjs = mjs_crs(jj) 982 ijje = mje_crs(jj) 983 984 p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) ) 985 986 ze3crs = SUM( p_e1(ijis:ijie,ijje) * p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) ) 987 IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj) 2226 988 2227 989 ENDDO 2228 990 ENDDO 2229 991 ENDDO 992 2230 993 CASE ('W') 2231 994 2232 DO jk = 2 , jpk 2233 DO ji = nistr, niend, nn_factx 2234 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2235 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 2236 2237 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2238 2239 jj = mje_crs(2) 2240 2241 2242 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 2243 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 2244 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1)) 2245 2246 p_e3_max_crs(ii,2,jk) = ze3crs 2247 2248 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk-1) + & 2249 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) + & 2250 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) 2251 2252 2253 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2254 ENDIF 2255 ELSE 2256 jj = mjs_crs(2) 2257 2258 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 2259 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 2260 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1), & 2261 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1), & 2262 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1), & 2263 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1), & 2264 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1), & 2265 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1), & 2266 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 2267 2268 p_e3_max_crs(ii,2,jk) = ze3crs 2269 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk-1) + & 2270 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) + & 2271 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) + & 2272 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk-1) + & 2273 & p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) + & 2274 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) + & 2275 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk-1) + & 2276 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) + & 2277 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1) 2278 2279 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2280 ENDIF 2281 2282 2283 DO jj = njstr, njend, nn_facty 2284 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 2285 ij = ( jj - njstr ) * rfacty_r + 3 2286 ijje = mje_crs(ij) 2287 ijie = mie_crs(ii) 2288 ! 2289 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 2290 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 2291 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1), & 2292 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1), & 2293 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1), & 2294 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1), & 2295 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1), & 2296 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1), & 2297 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 2298 2299 p_e3_max_crs(ii,ij,jk) = ze3crs 2300 2301 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk-1) + & 2302 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) + & 2303 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) + & 2304 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk-1) + & 2305 & p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) + & 2306 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) + & 2307 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk-1) + & 2308 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) + & 2309 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1) 2310 2311 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 995 DO jk = 1, jpk 996 DO ji = nldi_crs, nlei_crs 997 998 ijis = mis_crs(ji) 999 ijie = mie_crs(ji) 1000 1001 DO jj = nldj_crs, nlej_crs 1002 1003 ijjs = mjs_crs(jj) 1004 ijje = mje_crs(jj) 1005 1006 p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 1007 1008 ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 1009 IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk) 2312 1010 2313 1011 ENDDO … … 2315 1013 ENDDO 2316 1014 2317 2318 !first level 2319 DO ji = nistr, niend, nn_factx 2320 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2321 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 2322 2323 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2324 2325 jj = mje_crs(2) 2326 2327 ze3crs = MAX( p_e3(ji ,jj ,1) * p_mask(ji ,jj ,1), & 2328 & p_e3(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 2329 & p_e3(ji+2,jj ,1) * p_mask(ji+2,jj ,1)) 2330 2331 p_e3_max_crs(ii,2,1) = ze3crs 2332 2333 ze3crs = p_e3(ji ,jj ,1) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,1) + & 2334 & p_e3(ji+1,jj ,1) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,1) + & 2335 & p_e3(ji+2,jj ,1) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,1) 2336 2337 p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1) 2338 ENDIF 2339 ELSE 2340 jj = mjs_crs(2) 2341 2342 ze3crs = MAX( p_e3(ji ,jj ,1) * p_mask(ji ,jj ,1), & 2343 & p_e3(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 2344 & p_e3(ji+2,jj ,1) * p_mask(ji+2,jj ,1), & 2345 & p_e3(ji ,jj+1,1) * p_mask(ji ,jj+1,1), & 2346 & p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1), & 2347 & p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1), & 2348 & p_e3(ji ,jj+2,1) * p_mask(ji ,jj+2,1), & 2349 & p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1), & 2350 & p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 2351 2352 p_e3_max_crs(ii,2,1) = ze3crs 2353 ze3crs = p_e3(ji ,jj ,1) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,1) + & 2354 & p_e3(ji+1,jj ,1) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,1) + & 2355 & p_e3(ji+2,jj ,1) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,1) + & 2356 & p_e3(ji ,jj+1,1) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,1) + & 2357 & p_e3(ji+1,jj+1,1) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + & 2358 & p_e3(ji+2,jj+1,1) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + & 2359 & p_e3(ji ,jj+2,1) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,1) + & 2360 & p_e3(ji+1,jj+2,1) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + & 2361 & p_e3(ji+2,jj+2,1) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,1) 2362 2363 p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1) 2364 2365 ENDIF 2366 DO jj = njstr, njend, nn_facty 2367 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 2368 ij = ( jj - njstr ) * rfacty_r + 3 2369 ijje = mje_crs(ij) 2370 ijie = mie_crs(ii) 2371 ! 2372 ze3crs = MAX( p_e3(ji ,jj ,1) * p_mask(ji ,jj ,1), & 2373 & p_e3(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 2374 & p_e3(ji+2,jj ,1) * p_mask(ji+2,jj ,1), & 2375 & p_e3(ji ,jj+1,1) * p_mask(ji ,jj+1,1), & 2376 & p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1), & 2377 & p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1), & 2378 & p_e3(ji ,jj+2,1) * p_mask(ji ,jj+2,1), & 2379 & p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1), & 2380 & p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 2381 2382 p_e3_max_crs(ii,ij,1) = ze3crs 2383 2384 ze3crs = p_e3(ji ,jj ,1) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,1) + & 2385 & p_e3(ji+1,jj ,1) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,1) + & 2386 & p_e3(ji+2,jj ,1) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,1) + & 2387 & p_e3(ji ,jj+1,1) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,1) + & 2388 & p_e3(ji+1,jj+1,1) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + & 2389 & p_e3(ji+2,jj+1,1) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + & 2390 & p_e3(ji ,jj+2,1) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,1) + & 2391 & p_e3(ji+1,jj+2,1) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + & 2392 & p_e3(ji+2,jj+2,1) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,1) 2393 2394 p_e3_crs(ii,ij,1) = ze3crs / p_sfc_crs(ii,ij,1) 2395 2396 ENDDO 2397 ENDDO 2398 ! 2399 END SELECT 2400 2401 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 2402 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pval=1.0 ) 2403 ! 2404 !CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zmask ) 2405 ! 1015 END SELECT 1016 1017 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 1018 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pval=1.0 ) 1019 2406 1020 END SUBROUTINE crs_dom_e3 2407 1021 2408 SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk, p_e1, p_e2, p_e3 ) 2409 1022 SUBROUTINE crs_dom_sfc(p_mask, cd_type, p_surf_crs, p_surf_crs_msk, p_e1, p_e2, p_e3 ) 1023 !!========================================================================================= 1024 !! 1025 !! 1026 !!========================================================================================= 2410 1027 !! Arguments 2411 1028 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) … … 2418 1035 !! Local variables 2419 1036 INTEGER :: ji, jj, jk ! dummy loop indices 2420 INTEGER :: ii, ij, je_2 2421 INTEGER :: iji,ijj 1037 INTEGER :: ijis,ijie,ijjs,ijje 2422 1038 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk 2423 1039 !!---------------------------------------------------------------- … … 2434 1050 zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 2435 1051 ENDDO 2436 !zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1)2437 !cbr DO jk = 2, jpk2438 DO jk = 1, jpk2439 !cbr zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1)2440 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)2441 ENDDO2442 1052 2443 1053 CASE ('V') … … 2445 1055 zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) 2446 1056 ENDDO 2447 DO jk = 1, jpk 2448 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 2449 ENDDO 2450 1057 2451 1058 CASE ('U') 2452 1059 DO jk = 1, jpk 2453 1060 zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) 2454 1061 ENDDO 2455 DO jk = 1, jpk2456 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)2457 ENDDO2458 1062 2459 1063 CASE DEFAULT … … 2461 1065 zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 2462 1066 ENDDO 1067 END SELECT 1068 1069 DO jk = 1, jpk 1070 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 1071 ENDDO 1072 1073 SELECT CASE ( cd_type ) 1074 1075 CASE ('W') 1076 2463 1077 DO jk = 1, jpk 2464 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 2465 ENDDO 1078 DO jj = nldj_crs,nlej_crs 1079 ijjs=mjs_crs(jj) 1080 ijje=mje_crs(jj) 1081 DO ji = nldi_crs,nlei_crs 1082 ijis=mis_crs(ji) 1083 ijie=mie_crs(ji) 1084 p_surf_crs (ji,jj,jk) = SUM(zsurf (ijis:ijie,ijjs:ijje,jk) ) 1085 p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 1086 ENDDO 1087 ENDDO 1088 ENDDO 1089 1090 CASE ('U') 1091 1092 DO jk = 1, jpk 1093 DO jj = nldj_crs,nlej_crs 1094 ijjs=mjs_crs(jj) 1095 ijje=mje_crs(jj) 1096 DO ji = nldi_crs,nlei_crs 1097 ijis=mis_crs(ji) 1098 ijie=mie_crs(ji) 1099 p_surf_crs (ji,jj,jk) = SUM(zsurf (ijie,ijjs:ijje,jk) ) 1100 p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijie,ijjs:ijje,jk) ) 1101 ENDDO 1102 ENDDO 1103 ENDDO 1104 1105 CASE ('V') 1106 1107 DO jk = 1, jpk 1108 DO jj = nldj_crs,nlej_crs 1109 ijjs=mjs_crs(jj) 1110 ijje=mje_crs(jj) 1111 DO ji = nldi_crs,nlei_crs 1112 ijis=mis_crs(ji) 1113 ijie=mie_crs(ji) 1114 p_surf_crs (ji,jj,jk) = SUM(zsurf (ijis:ijie,ijje,jk) ) 1115 p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijis:ijie,ijje,jk) ) 1116 ENDDO 1117 ENDDO 1118 ENDDO 1119 2466 1120 END SELECT 2467 1121 2468 !WRITE(narea+200,*)"TOTO",nldj_crs,mjs_crs(1), mje_crs(1),mjs_crs(2), mje_crs(2),mjs_crs(3), mje_crs(3),mjs_crs(4), mje_crs(4) ; CALL FLUSH(narea+200) 2469 2470 SELECT CASE ( cd_type ) 2471 2472 CASE ('W') 2473 2474 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 2475 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2476 je_2 = mje_crs(2) 2477 DO jk = 1, jpk 2478 DO ji = nistr, niend, nn_factx 2479 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2480 ! 2481 p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 2482 & + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk) ! Why ????? 2483 ! 2484 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 2485 ! 2486 ENDDO 2487 ENDDO 2488 ENDIF 2489 ELSE 2490 je_2 = mjs_crs(2) 2491 DO jk = 1, jpk 2492 DO ji = nistr, niend, nn_factx 2493 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2494 ! 2495 p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 2496 & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 2497 & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 2498 2499 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2 ,jk) + zsurfmsk(ji+1,je_2 ,jk) + zsurfmsk(ji+2,je_2 ,jk) & 2500 & + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk) & 2501 & + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) 2502 ENDDO 2503 ENDDO 2504 ENDIF 2505 2506 DO jk = 1, jpk 2507 DO jj = njstr, njend, nn_facty 2508 DO ji = nistr, niend, nn_factx 2509 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2510 ij = ( jj - njstr ) * rfacty_r + 3 2511 ! 2512 p_surf_crs (ii,ij,jk) = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 2513 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 2514 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 2515 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj ,jk) + zsurfmsk(ji+1,jj ,jk) + zsurfmsk(ji+2,jj ,jk) & 2516 & + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk) & 2517 & + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 2518 2519 ENDDO 2520 ENDDO 2521 ENDDO 2522 2523 CASE ('U') 2524 2525 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 2526 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2527 je_2 = mje_crs(2) 2528 DO jk = 1, jpk 2529 DO ji = nistr, niend, nn_factx 2530 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2531 ! 2532 p_surf_crs (ii,2,jk) = zsurf(ji+2,je_2 ,jk) 2533 ! 2534 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji+2,je_2,jk) 2535 ! 2536 ENDDO 2537 ENDDO 2538 ENDIF 2539 ELSE 2540 je_2 = mjs_crs(2) 2541 DO jk = 1, jpk 2542 DO ji = nistr, niend, nn_factx 2543 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2544 ! 2545 p_surf_crs (ii,2,jk) = zsurf(ji+2,je_2 ,jk) & 2546 & + zsurf(ji+2,je_2+1,jk) & 2547 & + zsurf(ji+2,je_2+2,jk) 2548 2549 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji+2,je_2 ,jk) & 2550 & + zsurfmsk(ji+2,je_2+1,jk) & 2551 & + zsurfmsk(ji+2,je_2+2,jk) 2552 ENDDO 2553 ENDDO 2554 ENDIF 2555 2556 DO jk = 1, jpk 2557 DO jj = njstr, njend, nn_facty 2558 DO ji = nistr, niend, nn_factx 2559 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2560 ij = ( jj - njstr ) * rfacty_r + 3 2561 ! 2562 p_surf_crs (ii,ij,jk) = zsurf(ji+2,jj ,jk) & 2563 & + zsurf(ji+2,jj+1,jk) & 2564 & + zsurf(ji+2,jj+2,jk) 2565 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji+2,jj ,jk) & 2566 & + zsurfmsk(ji+2,jj+1,jk) & 2567 & + zsurfmsk(ji+2,jj+2,jk) 2568 ENDDO 2569 ENDDO 2570 ENDDO 2571 2572 CASE ('V') 2573 2574 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 2575 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2576 je_2 = mje_crs(2) 2577 DO jk = 1, jpk 2578 DO ji = nistr, niend, nn_factx 2579 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2580 ! 2581 p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) 2582 ! 2583 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 2584 ! 2585 ENDDO 2586 ENDDO 2587 ENDIF 2588 ELSE 2589 je_2 = mjs_crs(2) 2590 DO jk = 1, jpk 2591 DO ji = nistr, niend, nn_factx 2592 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2593 ! 2594 p_surf_crs (ii,2,jk) = zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 2595 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) 2596 ENDDO 2597 ENDDO 2598 ENDIF 2599 2600 DO jk = 1, jpk 2601 DO jj = njstr, njend, nn_facty 2602 DO ji = nistr, niend, nn_factx 2603 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2604 ij = ( jj - njstr ) * rfacty_r + 3 2605 ! 2606 p_surf_crs (ii,ij,jk) = zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 2607 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 2608 !iji=117 ; ijj=210 2609 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 2610 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 2611 !WRITE(narea+5000,*)"SFC V =======> " 2612 !WRITE(narea+5000,*)ii,ij,jk 2613 !WRITE(narea+5000,*)ji,jj 2614 !WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk),zsurfmsk(ji+1,jj+2,jk),zsurfmsk(ji+2,jj+2,jk) 2615 !WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk) 2616 !ENDIF 2617 ENDDO 2618 ENDDO 2619 ENDDO 2620 2621 END SELECT 2622 !DO jk=1,jpk 2623 !DO ji=1,jpi_crs 2624 !DO jj=1,jpj_crs 2625 ! IF( p_surf_crs_msk(ji,jj,jk) .NE. p_surf_crs_msk(ji,jj,jk) )WRITE(narea+200,*)"SFC 4 ",ji,jj,jk,p_surf_crs_msk(ji,jj,jk) ; call flush(narea+200) 2626 !ENDDO 2627 !ENDDO 2628 !ENDDO 2629 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, pval=1.0 ) 2630 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 1122 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0 ) !cbr , pval=1.0 ) 1123 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0 ) !cbr , pval=1.0 ) 2631 1124 2632 1125 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) … … 2647 1140 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices 2648 1141 INTEGER :: ierr ! allocation error status 2649 INTEGER :: ii,ij,iproc,iprocno,iprocso,iimppt_crs 1142 INTEGER :: iproci,iprocj,iproc,iprocno,iprocso,iimppt_crs 1143 INTEGER :: ii_start,ii_end,ij_start,ij_end 2650 1144 2651 1145 … … 2654 1148 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj 2655 1149 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 3 2656 jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 31150 jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 2 2657 1151 jpiglo_crsm1 = jpiglo_crs - 1 2658 1152 jpjglo_crsm1 = jpjglo_crs - 1 2659 1153 2660 1154 jpi_crs = ( jpiglo_crs - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci 2661 jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj 2662 !WRITE(narea+200,*)"jpj_crs noso = ", jpj_crs , noso 2663 IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors ! celle qui est faite de zeros 2664 !WRITE(narea+200,*)"jpj_crs = ", jpj_crs 1155 jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj 1156 !cbr? IF( njmpp==1 )THEN 1157 ! jpj_crs=jpj_crs+1 1158 ! ENDIF 1159 2665 1160 2666 1161 jpi_crsm1 = jpi_crs - 1 … … 2695 1190 ! mpp_ini2 2696 1191 !============================================================================================== 2697 2698 !cbr 2699 DO jn = 1, jpnij 2700 !WRITE(narea+200,*)"=====> jn",jn ; call flush(narea+200) 2701 2702 !proc jn 2703 DO ji = 1 , jpni 2704 DO jj = 1 ,jpnj 2705 IF( nfipproc(ji,jj) == jn-1 )THEN 2706 ii=ji 2707 ij=jj 2708 ENDIF 2709 ENDDO 2710 ENDDO 2711 iproc = ii + jpni * ( ij-1 ) - 1 2712 ! mppini : 2713 !iprocso = ii + jpni * ( ij-2 ) - 1 2714 ! mppini2: 2715 IF( ij .GT. 1 )THEN ; iprocso = nfipproc(ii,ij-1) 2716 ELSE ; iprocso = -1 1192 DO ji = 1 , jpni 1193 DO jj = 1 ,jpnj 1194 IF( nfipproc(ji,jj) == narea-1 )THEN 1195 iproci=ji 1196 iprocj=jj 1197 ENDIF 1198 ENDDO 1199 ENDDO 1200 1201 !WRITE(narea+8000-1,*)"nfipproc(ji,jj),narea :",nfipproc(iproci,iprocj),narea 1202 !WRITE(narea+8000-1,*)"proc i,j ",iproci,iprocj 1203 !WRITE(narea+8000-1,*)"nowe noea",nowe,noea 1204 !WRITE(narea+8000-1,*)"noso nono",noso,nono 1205 !WRITE(narea+8000-1,*)"nbondi nbondj ",nbondi,nbondj 1206 !WRITE(narea+8000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo 1207 !WRITE(narea+8000-1,*)"jpi jpj ",jpi,jpj 1208 !WRITE(narea+8000-1,*)"nbondi nbondj",nbondi,nbondj 1209 !WRITE(narea+8000-1,*)"nimpp njmpp ",nimpp,njmpp 1210 !WRITE(narea+8000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi ,nlei ,nlci 1211 !WRITE(narea+8000-1,*)"glo jpi nldi,nlei ",jpi, nldi+nimpp-1,nlei+nimpp-1 1212 !WRITE(narea+8000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj ,nlej ,nlcj 1213 !WRITE(narea+8000-1,*)"glo jpj nldj,nlej ",jpj, nldj+njmpp-1,nlej+njmpp-1 1214 !WRITE(narea+8000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs 1215 !WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs 1216 !WRITE(narea+8000-1,*)"jpni jpnj jpnij ",jpni,jpnj,jpnij 1217 !WRITE(narea+8000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj) 1218 !========================================================================== 1219 ! dim along I 1220 !========================================================================== 1221 SELECT CASE ( nperio ) 1222 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 1223 1224 DO ji=1,jpiglo_crs 1225 ijis=nn_factx*(ji-1)-2 1226 ijie=nn_factx*(ji-1) 1227 mis2_crs(ji)=ijis 1228 mie2_crs(ji)=ijie 1229 ENDDO 1230 1231 ji=1 1232 DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 ) 1233 ji=ji+1 1234 IF( ji==jpiglo_crs )EXIT 1235 END DO 1236 ijis=ji 1237 1238 !mjs2_crs(ijis)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur 1239 !ijis =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur 1240 !ii_start =indice local de mjs2_crs(jj) 1241 ii_start = mis2_crs(ijis)-nimpp+1 1242 nimpp_crs = ijis-1 1243 1244 nldi_crs = 2 1245 IF( nowe == -1 )THEN 1246 1247 mie2_crs(ijis-1) = mis2_crs(ijis)-1 1248 1249 SELECT CASE(ii_start) 1250 CASE(1) 1251 nldi_crs=2 1252 mie2_crs(ijis-1) = -1 1253 mis2_crs(ijis-1) = -1 1254 CASE(2) 1255 !CBR? nldi_crs=1 1256 nldi_crs=2 1257 mis2_crs(ijis-1) = mie2_crs(ijis-1) 1258 CASE(3) 1259 !CBR? nldi_crs=1 1260 nldi_crs=2 1261 mis2_crs(ijis-1) = mie2_crs(ijis-1) -1 1262 CASE DEFAULT 1263 WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start 1264 END SELECT 1265 1266 ENDIF 1267 1268 IF( nimpp==1 )nimpp_crs=1 1269 1270 !---------------------------------------- 1271 ji=jpiglo_crs 1272 DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. jpi ) 1273 ji=ji-1 1274 IF( ji==1 )EXIT 1275 END DO 1276 ijie=ji 1277 nlei_crs=ijie-nimpp_crs+1 1278 nlci_crs=nlei_crs+jpreci 1279 1280 !---------------------------------------- 1281 DO ji = 1, jpi_crs 1282 mig_crs(ji) = ji + nimpp_crs - 1 1283 ENDDO 1284 DO ji = 1, jpiglo_crs 1285 mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 1286 mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) ) 1287 ENDDO 1288 1289 !---------------------------------------- 1290 DO ji = 1, nlei_crs 1291 mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 1292 mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 1293 nfactx(ji) = mie_crs(ji)-mie_crs(ji)+1 1294 ENDDO 1295 1296 IF( iproci == jpni )THEN 1297 nlei_crs=nlci_crs 1298 mis_crs(nlei_crs)=mis_crs(nlei_crs-1) 1299 mie_crs(nlei_crs)=mie_crs(nlei_crs-1) 1300 ENDIF 1301 1302 !---------------------------------------- 1303 1304 CASE DEFAULT 1305 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported' 1306 END SELECT 1307 1308 !========================================================================== 1309 ! dim along J 1310 !========================================================================== 1311 SELECT CASE ( nperio ) 1312 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 1313 1314 DO jj=1,jpjglo_crs 1315 ijjs=nn_facty*(jj)-5 1316 ijje=nn_facty*(jj)-3 1317 mjs2_crs(jj)=ijjs 1318 mje2_crs(jj)=ijje 1319 ENDDO 1320 1321 jj=1 1322 DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 ) 1323 jj=jj+1 1324 IF( jj==jpjglo_crs )EXIT 1325 END DO 1326 ijjs=jj 1327 1328 !mjs2_crs(jj)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur 1329 !ijjs =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur 1330 !ij_start =indice local de mjs2_crs(jj) 1331 ij_start = mjs2_crs(ijjs)-njmpp+1 1332 njmpp_crs = ijjs-1 1333 1334 nldj_crs = 2 1335 IF( noso == -1 )THEN 1336 1337 mje2_crs(ijjs-1) = mjs2_crs(ijjs)-1 1338 1339 SELECT CASE(ij_start) 1340 CASE(1) 1341 nldj_crs=2 1342 mje2_crs(ijjs-1) = -1 1343 mjs2_crs(ijjs-1) = -1 1344 CASE(2) 1345 !CBR? nldj_crs=1 1346 nldj_crs=2 1347 mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) 1348 CASE(3) 1349 !CBR? nldj_crs=1 1350 nldj_crs=2 1351 mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) -1 1352 CASE DEFAULT 1353 WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start 1354 END SELECT 1355 1356 ENDIF 1357 IF( njmpp==1 )njmpp_crs=1 1358 1359 1360 !---------------------------------------- 1361 jj=jpjglo_crs 1362 DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj ) 1363 jj=jj-1 1364 IF( jj==1 )EXIT 1365 END DO 1366 ijje=jj 1367 1368 nlej_crs=ijje-njmpp_crs+1 1369 1370 !---------------------------------------- 1371 nlcj_crs=nlej_crs+jprecj 1372 IF( iprocj == jpnj )THEN 1373 nlej_crs=jpj_crs ! cbr -1 ???????????????????? 1374 nlcj_crs=nlej_crs 2717 1375 ENDIF 2718 1376 2719 !WRITE(narea+200,*)ii,ij ; call flush(narea+200) 2720 !WRITE(narea+200,*)"iproc iprocso ",iproc,iprocso 2721 !WRITE(narea+200,*)"jpiglo jpjglo ",jpiglo,jpjglo 2722 !WRITE(narea+200,*)"ibonit(jn) ibonjt(jn) ",ibonit(jn),ibonjt(jn) ; call flush(narea+200) 2723 !WRITE(narea+200,*)"nimppt(jn) njmppt(jn) ",nimppt(jn),njmppt(jn) ; call flush(narea+200) 2724 !WRITE(narea+200,*)"loc jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn),nlejt(jn),nlcjt(jn) ; call flush(narea+200) 2725 !WRITE(narea+200,*)"glo jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn)+njmppt(jn)-1,nlejt(jn)+njmppt(jn)-1,nlcjt(jn) ; call flush(narea+200) 2726 2727 !dimension selon j 2728 !------------------- 2729 IF( ibonjt(jn) .NE. 1 )THEN !on a besoin de savoir si jn est au nord 2730 !iprocno=nfipproc(ii,ij+1) 2731 !iprocno=iprocno+1 2732 !WRITE(narea+200,*)"ii,ij+1 ",ii,ij+1; call flush(narea+200) 2733 !WRITE(narea+200,*)"njmppt jn njmpptno(jn) ",njmppt(jn),njmpptno(jn); call flush(narea+200) 2734 !WRITE(narea+200,*)"jpjglo",jpjglo ; call flush(narea+200) 2735 2736 !WRITE(narea+200,*)REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ),REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ); call flush(narea+200) 2737 !WRITE(narea+200,*)AINT( REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ) ),AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) ); call flush(narea+200) 2738 2739 nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ) ) & 2740 & - AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) ) 2741 ELSE ! ibonjt=1 : au nord 2742 nlejt_crs(jn) = AINT( REAL( nlejt(jn) / nn_facty, wp ) ) + 1 1377 !---------------------------------------- 1378 DO jj = 1, jpj_crs 1379 mjg_crs(jj) = jj + njmpp_crs - 1 1380 ENDDO 1381 DO jj = 1, jpjglo_crs 1382 mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 1383 mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) 1384 ENDDO 1385 1386 !---------------------------------------- 1387 DO jj = 1, nlej_crs 1388 mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 1389 mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 1390 nfacty(jj) = mje_crs(jj)-mje_crs(jj)+1 1391 ENDDO 1392 1393 IF( iprocj == jpnj )THEN 1394 mjs_crs(nlej_crs)=mjs_crs(nlej_crs-1) 1395 mje_crs(nlej_crs)=mje_crs(nlej_crs-1) 2743 1396 ENDIF 2744 !==> nbondj = -1 au sud, 0 au milieu, 1 au nord, 2 si jpnj=1 2745 !WRITE(narea+200,*)"nlejt_crs(jn) ",nlejt_crs(jn) ; call flush(narea+200) 2746 !!!noso== nbre de proc sud du proc sur lequel on tourne !!!! ; dangeureux car on est ds une boucle sur jn 2747 IF( iprocso < 0 .AND. ibonjt(jn) == -1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 2748 SELECT CASE( ibonjt(jn) ) 2749 CASE ( -1 ) 2750 !WRITE(narea+200,*)"MOD( jpjglo - njmppt(jn), nn_facty)",MOD( jpjglo - njmppt(jn), nn_facty) ; call flush(narea+200) 2751 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 ! au cas où il reste des lignes en bas 2752 IF( nldjt(jn) == 1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 2753 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 2754 nldjt_crs(jn) = nldjt(jn) 2755 !???nlejt_crs(jn) = nlejt_crs(jn) + 1 ! 2 !cbr 2756 CASE ( 0 ) 2757 2758 nldjt_crs(jn) = nldjt(jn) 2759 IF( nldjt(jn) == 1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 2760 nlejt_crs(jn) = nlejt_crs(jn) + jprecj 2761 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 2762 2763 CASE ( 1, 2 ) 2764 2765 nlejt_crs(jn) = nlejt_crs(jn) + jprecj 2766 nlcjt_crs(jn) = nlejt_crs(jn) 2767 nldjt_crs(jn) = nldjt(jn) 2768 CASE DEFAULT 2769 STOP 2770 END SELECT 2771 !WRITE(narea+200,*)"jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) " ; call flush(narea+200) 2772 !WRITE(narea+200,*) jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200) 2773 IF( nlcjt_crs(jn) > jpj_crs )THEN 2774 jpj_crs = jpj_crs + 1 2775 nlejt_crs(jn) = nlejt_crs(jn) + 1 2776 ENDIF 2777 !cbr pas bon !!!! 2778 !on augmente la taille des domaines alors que les tblx st deja alloués 2779 !du coup on alloue les tblx apres: 2780 IF(nldjt_crs(jn) == 1 ) THEN 2781 njmppt_crs(jn) = 1 2782 ELSE 2783 njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) 2784 ENDIF 2785 !WRITE(narea+200,*)"tutu loc ",jn,jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200) 2786 !WRITE(narea+200,*)"tutu glo ",jn,jpj_crs, nldjt_crs(jn)+njmppt_crs(jn)-1,nlejt_crs(jn)+njmppt_crs(jn)-1,nlcjt_crs(jn)+njmppt_crs(jn)-1 ; call flush(narea+200) 2787 2788 2789 !dimensions selon i 2790 !------------------- 2791 !IF( jn == 1 ) THEN 2792 !IF( ibonit(jn)==-1 )THEN !on a besoin de savoir si jn est un proc west 2793 IF( ii==1 )THEN !on a besoin de savoir si jn est un proc west 2794 nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) 2795 ELSE 2796 !WRITE(narea+200,*)"njmppt jn njmpptea(jn) ",nimppt(jn),nimpptea(jn); call flush(narea+200) 2797 !WRITE(narea+200,*)"nlcit (jn) nlcitea(jn) ) ",nlcit (jn),nlcitea(jn); call flush(narea+200) 2798 nleit_crs(jn) = AINT( REAL( ( nimppt (jn) - 1 + nlcit (jn) ) / nn_factx, wp) ) & 2799 & - AINT( REAL( ( nimpptea(jn) - 1 + nlcitea(jn) ) / nn_factx, wp) ) 2800 ENDIF 2801 !WRITE(narea+200,*)"nleji_crs(jn),noso ",nleit_crs(jn); call flush(narea+200) 2802 2803 2804 SELECT CASE( ibonit(jn) ) 2805 CASE ( -1 ) 2806 nleit_crs(jn) = nleit_crs(jn) + jpreci 2807 nlcit_crs(jn) = nleit_crs(jn) + jpreci 2808 nldit_crs(jn) = nldit(jn) 2809 2810 CASE ( 0 ) 2811 nleit_crs(jn) = nleit_crs(jn) + jpreci 2812 nlcit_crs(jn) = nleit_crs(jn) + jpreci 2813 nldit_crs(jn) = nldit(jn) 2814 2815 CASE ( 1, 2 ) 2816 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nleit_crs(jn) = nleit_crs(jn) + 1 2817 nleit_crs(jn) = nleit_crs(jn) + jpreci 2818 nlcit_crs(jn) = nleit_crs(jn) 2819 nldit_crs(jn) = nldit(jn) 2820 2821 CASE DEFAULT 2822 STOP 2823 END SELECT 2824 !WRITE(narea+200,*)"jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ",jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200) 2825 nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 2826 2827 !WRITE(narea+200,*)"tutu loc ",jn,jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200) 2828 !WRITE(narea+200,*)"tutu glo ",jn,jpi_crs, nldit_crs(jn)+nimppt_crs(jn)-1,nleit_crs(jn)+nimppt_crs(jn)-1,nlcit_crs(jn)+nimppt_crs(jn)-1 ; call flush(narea+200) 2829 2830 nfiimpp_crs(ii,ij) = nimppt_crs(jn) 2831 !WRITE(narea+200,*)"tutu nimppt_crs(jn) ",ii,ij,nimppt_crs(jn) ; call flush(narea+200) 2832 2833 ENDDO 2834 2835 DO ji = 1 , jpni 2836 DO jj = 1 ,jpnj 1397 1398 !---------------------------------------- 1399 1400 CASE DEFAULT 1401 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported' 1402 END SELECT 1403 1404 !========================================================================== 1405 IF( nlci_crs .GT. jpi_crs .OR. nlei_crs .GT. jpi_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlei_crs,nlci_crs,jpi_crs; CALL FLUSH(narea+8000-1) 1406 IF( nlcj_crs .GT. jpj_crs .OR. nlej_crs .GT. jpj_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlej_crs,nlcj_crs,jpj_crs; CALL FLUSH(narea+8000-1) 1407 !========================================================================== 1408 1409 nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0 1410 nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0 1411 1412 CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs) 1413 CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs) 1414 CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs) 1415 CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs) 1416 1417 DO jj = 1 ,jpnj 1418 DO ji = 1 , jpni 2837 1419 jn=nfipproc(ji,jj)+1 2838 iimppt_crs = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1 2839 nfiimpp_crs(ji,jj) = iimppt_crs 2840 IF( jn .GE. 1 )nimppt_crs(jn) = iimppt_crs 2841 !PRINT*," nfiimpp_crs(ji,jj) ",ji,jj,jn,nfiimpp(ji,jj),nfiimpp_crs(ji,jj) 1420 IF( jn .GE. 1 )THEN 1421 nfiimpp_crs(ji,jj)=nimppt_crs(jn) 1422 ELSE 1423 nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1 1424 ENDIF 2842 1425 ENDDO 2843 1426 ENDDO 2844 2845 nlej_crs = nlejt_crs(nproc + 1) 2846 nlcj_crs = nlcjt_crs(nproc + 1) 2847 nldj_crs = nldjt_crs(nproc + 1) 2848 njmpp_crs = njmppt_crs(nproc + 1) 2849 2850 nlei_crs = nleit_crs(nproc + 1) 2851 nlci_crs = nlcit_crs(nproc + 1) 2852 nldi_crs = nldit_crs(nproc + 1) 2853 nimpp_crs = nimppt_crs(nproc + 1) 2854 1427 2855 1428 !nogather=T 2856 1429 nfsloop_crs = 1 … … 2867 1440 END DO 2868 1441 1442 !WRITE(narea+8000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs ,nlei_crs ,nlci_crs 1443 !WRITE(narea+8000-1,*)"glo crs jpi nldi,nlei ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 1444 !WRITE(narea+8000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs ,nlej_crs ,nlcj_crs 1445 !WRITE(narea+8000-1,*)"glo crs jpj nldj,nlej ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 2869 1446 !============================================================================================== 2870 !write(narea+200,*)"jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1" ; call flush(narea+200)2871 !write(narea+200,*)jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 ; call flush(narea+200)2872 !write(narea+200,*)"jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1" ; call flush(narea+200)2873 !write(narea+200,*)jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 ; call flush(narea+200)2874 !write(narea+200,*)"nfsloop_crs nfeloop_crs ",nfsloop_crs,nfeloop_crs ; call flush(narea+200)2875 2876 ! No coarsening with zoom2877 1447 IF( jpizoom /= 1 .OR. jpjzoom /= 1) STOP 2878 1448 2879 !cbr2880 ierr = crs_dom_alloc1()2881 2882 DO ji = 1, jpi_crs2883 mig_crs(ji) = ji + nimpp_crs - 12884 !WRITE(narea+200,*)"fifi ",ji,mig_crs(ji) ; call flush(narea+200)2885 ENDDO2886 DO jj = 1, jpj_crs2887 mjg_crs(jj) = jj + njmpp_crs - 1!2888 !WRITE(narea+200,*)"fufu ",jj,mjg_crs(jj) ; call flush(narea+200)2889 ENDDO2890 2891 DO ji = 1, jpiglo_crs2892 mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )2893 mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) )2894 !WRITE(narea+200,*)"mi ",ji,mi0_crs(ji),mi1_crs(ji) ; call flush(narea+200)2895 ENDDO2896 2897 DO jj = 1, jpjglo_crs2898 mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )2899 mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) )2900 !WRITE(narea+200,*)"mj ",jj, mj0_crs(jj),mj1_crs(jj) ; call flush(narea+200)2901 ENDDO2902 2903 ENDIF2904 2905 1449 ! Save the parent grid information 2906 1450 jpi_full = jpi … … 2987 1531 rfactxy = nn_factx * nn_facty 2988 1532 2989 ! 2.b. Set up bins for coarse grid, horizontal only.2990 ierr = crs_dom_alloc2()2991 2992 mis2_crs(:) = 0 ; mie2_crs(:) = 02993 mjs2_crs(:) = 0 ; mje2_crs(:) = 02994 2995 2996 SELECT CASE ( nn_binref )2997 2998 CASE ( 0 )2999 3000 SELECT CASE ( nperio )3001 3002 3003 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold3004 3005 DO ji = 2, jpiglo_crsm13006 ijie = ( ji * nn_factx ) - nn_factx !cc3007 ijis = ijie - nn_factx + 13008 mis2_crs(ji) = ijis3009 mie2_crs(ji) = ijie3010 ENDDO3011 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 23012 3013 ! Handle first the northernmost bin3014 IF ( nn_facty == 2 ) THEN ; ijjgloT = jpjglo - 13015 ELSE ; ijjgloT = jpjglo3016 ENDIF3017 3018 DO jj = 2, jpjglo_crs3019 ijje = ijjgloT - nn_facty * ( jj - 3 )3020 ijjs = ijje - nn_facty + 13021 mjs2_crs(jpjglo_crs-jj+2) = ijjs3022 mje2_crs(jpjglo_crs-jj+2) = ijje3023 !WRITE(narea+200,*)"jpjglo_crs-jj+2,ijje,ijjs ",jpjglo_crs-jj+2,ijjs,ijje ; call flush(narea+200)3024 ENDDO3025 3026 CASE ( 2 )3027 WRITE(numout,*) 'crs_init, jperio=2 not supported'3028 3029 CASE ( 5, 6 ) ! F-pivot at North Fold3030 3031 DO ji = 2, jpiglo_crsm13032 ijie = ( ji * nn_factx ) - nn_factx3033 ijis = ijie - nn_factx + 13034 mis2_crs(ji) = ijis3035 mie2_crs(ji) = ijie3036 ENDDO3037 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo - 23038 3039 ! Treat the northernmost bin separately.3040 jj = 23041 ijje = jpj - nn_facty * ( jj - 2 )3042 IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 13043 ELSE ; ijjs = ijje - nn_facty + 13044 ENDIF3045 mjs2_crs(jpj_crs-jj+1) = ijjs3046 mje2_crs(jpj_crs-jj+1) = ijje3047 3048 ! Now bin the rest, any remainder at the south is lumped in the southern bin3049 DO jj = 3, jpjglo_crsm13050 ijje = jpjglo - nn_facty * ( jj - 2 )3051 ijjs = ijje - nn_facty + 13052 IF ( ijjs <= nn_facty ) ijjs = 23053 WRITE(narea+200,*)"fufu",jj,ijjs,ijje ; call flush(narea+200)3054 mjs2_crs(jpj_crs-jj+1) = ijjs3055 mje2_crs(jpj_crs-jj+1) = ijje3056 ENDDO3057 3058 CASE DEFAULT3059 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported'3060 3061 END SELECT3062 3063 CASE (1 )3064 WRITE(numout,*) 'crs_init. Equator-centered bins option not yet available'3065 3066 END SELECT3067 3068 ! Pad the boundaries, do not know if it is necessary3069 mis2_crs(2) = 1 ; mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 13070 mie2_crs(2) = nn_factx ; mie2_crs(jpiglo_crs) = jpiglo3071 !3072 mjs2_crs(1) = 13073 mje2_crs(1) = 13074 !3075 mje2_crs(2) = mjs2_crs(3)-1 ; mje2_crs(jpjglo_crs) = jpjglo3076 mjs2_crs(2) = 1 ; mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 13077 3078 IF( .NOT. lk_mpp ) THEN3079 mis_crs(:) = mis2_crs(:)3080 mie_crs(:) = mie2_crs(:)3081 mjs_crs(:) = mjs2_crs(:)3082 mje_crs(:) = mje2_crs(:)3083 ELSE3084 !write(narea+200,*)"njmpp ",njmpp3085 DO jj = 1, nlej_crs3086 !write(narea+200,*)jj,"mjs2_crs mje2_crs ",mjg_crs(jj),mjs2_crs(mjg_crs(jj)),mje2_crs(mjg_crs(jj)) ; call flush(narea+200)3087 mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 13088 mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 13089 !write(narea+200,*)"mjs_crs mje_crs ",mjs_crs(jj),mje_crs(jj) ; call flush(narea+200)3090 ENDDO3091 !write(narea+200,*)"nimpp ",nimpp3092 DO ji = 1, nlei_crs3093 !write(narea+200,*)ji,"mis2_crs mie2_crs ",mig_crs(ji),mis2_crs(mig_crs(ji)),mie2_crs(mig_crs(ji)) ; call flush(narea+200)3094 mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 13095 mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 13096 !write(narea+200,*)"mis_crs mie_crs ",mis_crs(jj),mie_crs(jj) ; call flush(narea+200)3097 ENDDO3098 1533 ENDIF 3099 1534 ! 3100 !IF( nlcj_crs -1 .GT. nlej_crs )WRITE(narea+200,*)"tutututu",nlcj_crs,nlej_crs ; call flush(narea+200)3101 1535 nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1) 3102 1536 njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_crs - 1) 1537 ! 3103 1538 ! 3104 1539 END SUBROUTINE crs_dom_def
Note: See TracChangeset
for help on using the changeset viewer.