- Timestamp:
- 2015-02-24T15:46:25+01:00 (9 years ago)
- Location:
- branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 9 added
- 9 edited
-
CRS/crs.F90 (modified) (8 diffs)
-
CRS/crsdom.F90 (modified) (21 diffs)
-
CRS/crsfld.F90 (modified) (12 diffs)
-
CRS/crsini.F90 (modified) (7 diffs)
-
DOM/dom_oce.F90 (modified) (2 diffs)
-
IOM/iom.F90 (modified) (1 diff)
-
LDF/ldfslp_crs.F90 (added)
-
TRA/eosbn2_crs.F90 (added)
-
TRA/traadv_tvd_crs.F90 (added)
-
TRA/trabbl_crs.F90 (added)
-
TRA/traldf_iso_crs.F90 (added)
-
TRA/traldf_lap_crs.F90 (added)
-
TRA/trazdf_imp_crs.F90 (added)
-
TRA/zpshde_crs.F90 (added)
-
ZDF/zdfmxl_crs.F90 (added)
-
nemogcm.F90 (modified) (2 diffs)
-
step.F90 (modified) (3 diffs)
-
step_oce.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90
r5010 r5105 94 94 95 95 ! Masks 96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tmask_crs, umask_crs, vmask_crs, fmask_crs97 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: tmask_i_crs, rnfmsk_crs, tpol_crs, fpol_crs96 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE,SAVE :: tmask_crs, umask_crs, vmask_crs, fmask_crs 97 REAL(wp), DIMENSION(:,:) , ALLOCATABLE,SAVE :: tmask_i_crs, rnfmsk_crs, tpol_crs, fpol_crs 98 98 99 99 ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmask_i_crs, tpol, fpol … … 112 112 ! vertical scale factors 113 113 ! Coordinates 114 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs115 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs116 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ff_crs117 INTEGER, DIMENSION(:,:), ALLOCATABLE :: mbathy_crs, mbkt_crs, mbku_crs, mbkv_crs118 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs114 REAL(wp), DIMENSION(:,:), ALLOCATABLE,SAVE :: gphit_crs, glamt_crs, gphif_crs, glamf_crs 115 REAL(wp), DIMENSION(:,:), ALLOCATABLE,SAVE :: gphiu_crs, glamu_crs, gphiv_crs, glamv_crs 116 REAL(wp), DIMENSION(:,:), ALLOCATABLE,SAVE :: ff_crs 117 INTEGER, DIMENSION(:,:), ALLOCATABLE,SAVE :: mbathy_crs, mbkt_crs, mbku_crs, mbkv_crs 118 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE,SAVE :: gdept_crs, gdepu_crs, gdepv_crs, gdepw_crs 119 119 120 120 ! Weights … … 136 136 INTEGER :: nn_crs_kz = 0 !: type of Kz coarsening ( =0->VOL ; =1->MAX ; =2->MIN) 137 137 LOGICAL :: ln_crs_wn = .FALSE. !: coarsening wn or computation using horizontal divergence 138 LOGICAL, PUBLIC :: ln_crs_top = .FALSE. !:coarsening online for the bio 138 139 ! 139 140 INTEGER :: nrestx, nresty !: for determining odd or even reduction factor … … 146 147 147 148 ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields 148 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ts n_crs149 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsb_crs,tsn_crs 149 150 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: un_crs, vn_crs, wn_crs, rke_crs 150 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivn_crs 151 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: sshn_crs 151 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ub_crs, vb_crs 152 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivb_crs , hdivn_crs 153 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: sshb_crs, sshn_crs , ssha_crs 154 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: rhop_crs,rhd_crs,rb2_crs 155 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: gru_crs, grv_crs 156 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: gtsu_crs, gtsv_crs 152 157 ! 153 158 ! Surface fluxes to pass to TOP 154 159 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: qsr_crs, fr_i_crs, wndm_crs 155 160 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: emp_crs, emp_b_crs, sfx_crs 161 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: fmmflx_crs 156 162 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: utau_crs, vtau_crs 157 163 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: rnf_crs … … 164 170 165 171 ! Mixing and Mixed Layer Depth 166 INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs 172 INTEGER, PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: nmln_crs 173 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: hmlp_crs , hmlpt_crs , hmld_crs 167 174 168 175 ! Direction of lateral diffusion … … 235 242 236 243 237 ALLOCATE( un_crs(jpi_crs,jpj_crs,jpk) , vn_crs(jpi_crs,jpj_crs,jpk) , & 238 & wn_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk),& 239 & rke_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(11)) 240 241 ALLOCATE( sshn_crs(jpi_crs,jpj_crs), emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), & 244 ALLOCATE( ub_crs(jpi_crs,jpj_crs,jpk) , vb_crs(jpi_crs,jpj_crs,jpk) , & 245 & un_crs(jpi_crs,jpj_crs,jpk) , vn_crs(jpi_crs,jpj_crs,jpk) , wn_crs(jpi_crs,jpj_crs,jpk) , & 246 & hdivb_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk) , & 247 & rke_crs(jpi_crs,jpj_crs,jpk), rhop_crs(jpi_crs,jpj_crs,jpk) , & 248 & rb2_crs(jpi_crs,jpj_crs,jpk) ,rhd_crs(jpi_crs,jpj_crs,jpk) , & 249 & gtsu_crs(jpi_crs,jpj_crs,jpk) ,gtsv_crs(jpi_crs,jpj_crs,jpk) , & 250 gru_crs(jpi_crs,jpj_crs) ,grv_crs(jpi_crs,jpj_crs) , STAT=ierr(11)) 251 252 ALLOCATE( sshb_crs(jpi_crs,jpj_crs), sshn_crs(jpi_crs,jpj_crs), ssha_crs(jpi_crs,jpj_crs), & 253 & emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), & 242 254 & qsr_crs(jpi_crs ,jpj_crs), wndm_crs(jpi_crs,jpj_crs), utau_crs(jpi_crs,jpj_crs) , & 243 255 & vtau_crs(jpi_crs,jpj_crs), rnf_crs(jpi_crs ,jpj_crs), & 244 & fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs), STAT=ierr(12) )245 246 ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), &256 & fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs), fmmflx_crs(jpi_crs ,jpj_crs), STAT=ierr(12) ) 257 258 ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsb_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), & 247 259 # if defined key_zdfddm 248 260 & avs_crs(jpi_crs,jpj_crs,jpk), & … … 302 314 !! ** Purpose : +Return back to parent grid domain 303 315 !!--------------------------------------------------------------------- 304 write(narea+200,*)"dom_grid_glo";call flush(narea+200)305 316 306 317 ! Return to parent grid domain … … 346 357 !! ** Purpose : Save the parent grid information & Switch to coarse grid domain 347 358 !!--------------------------------------------------------------------- 348 write(narea+200,*)"dom_grid_crs";call flush(narea+200)349 359 ! 350 360 ! Switch to coarse grid domain -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
r5010 r5105 52 52 END INTERFACE 53 53 54 REAL(wp) :: r_inf =1e+3654 REAL(wp),PUBLIC :: r_inf = 1e+7 !cbr 1e+36 55 55 56 56 !! Substitutions … … 64 64 INTEGER :: ji, jj, jk ! dummy loop indices 65 65 INTEGER :: ijie,ijis,ijje,ijjs,ij,je_2 66 INTEGER :: iji, ijj 66 67 REAL(wp) :: zmask 67 68 … … 122 123 ijjs = mjs_crs(jj) 123 124 124 IF( ijje .GT. jpj )WRITE(narea+200,*)"BUG",jj,ijjs,ijje,SHAPE(tmask) ; call flush(narea+200) 125 !iji=117 ; ijj=211 126 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 127 !IF( ji ==iji .AND. jj==ijj .AND. jk==74 )THEN 128 !write(narea+5000,*)"mask ",ji,jj 129 !write(narea+5000,*)"mask ",ijie,ijis,ijjs,ijje 130 !ENDIF 131 132 !IF( ijje .GT. jpj )WRITE(narea+200,*)"BUG",jj,ijjs,ijje,SHAPE(tmask) ; call flush(narea+200) 125 133 zmask = 0.0 126 134 zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) … … 140 148 ENDDO 141 149 ENDDO 150 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) 151 !cbr 152 !DO ji=1,jpi_crs-1 153 !DO jj=1,jpj_crs-1 154 !DO jk=1,jpk 155 ! umask_crs(ji,jj,jk) = tmask_crs(ji ,jj ,jk) * tmask_crs(ji+1,jj ,jk) 156 ! vmask_crs(ji,jj,jk) = tmask_crs(ji ,jj ,jk) * tmask_crs(ji ,jj+1,jk) 157 ! 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) 158 !ENDDO 159 !ENDDO 160 !ENDDO 142 161 ! 143 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )144 162 CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) 145 163 CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) 146 164 CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) 165 ! 166 !cbr 167 !DO ji=2,jpi_crs-1 168 !DO jj=2,jpj_crs-1 169 !DO jk=1,jpk 170 ! 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 171 ! 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 172 ! 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 173 ! 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 174 ! 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 175 ! 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 176 ! 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 177 ! 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 178 !ENDDO 179 !ENDDO 180 !ENDDO 147 181 ! 148 182 END SUBROUTINE crs_dom_msk … … 385 419 386 420 zmask(:,:,:) = 0.0 387 IF( cd_type == 'W' ) THEN388 zmask(:,:,1) = p_mask(:,:,1)389 DO jk = 2, jpk390 zmask(:,:,jk) = p_mask(:,:,jk-1)391 ENDDO392 ELSE421 !IF( cd_type == 'W' ) THEN 422 ! zmask(:,:,1) = p_mask(:,:,1) 423 ! DO jk = 2, jpk 424 ! zmask(:,:,jk) = p_mask(:,:,jk-1) 425 ! ENDDO 426 !ELSE 393 427 DO jk = 1, jpk 394 428 zmask(:,:,jk) = p_mask(:,:,jk) 395 429 ENDDO 396 ENDIF430 !ENDIF 397 431 398 432 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 … … 513 547 REAL(wp) :: zflcrs, zsfcrs 514 548 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask 549 INTEGER :: iji, ijj 515 550 !!---------------------------------------------------------------- 516 551 … … 526 561 527 562 CASE( 'T', 'W' ) 528 IF( cd_type == 'T' ) THEN563 !IF( cd_type == 'T' ) THEN 529 564 DO jk = 1, jpk 530 565 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 531 566 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 532 567 ENDDO 533 ELSE 534 zsurf (:,:,1) = p_e12(:,:) * p_e3(:,:,1) 535 zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 536 DO jk = 2, jpk 537 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) 538 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 539 ENDDO 540 ENDIF 568 !ELSE 569 ! !cbr ???????????????????????????????? 570 ! zsurf (:,:,1) = p_e12(:,:) * p_e3(:,:,1) 571 ! zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 572 ! DO jk = 2, jpk 573 ! zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) 574 ! zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 575 ! ENDDO 576 !ENDIF 541 577 542 578 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 … … 619 655 CASE( 'W' ) 620 656 IF( PRESENT( p_e3 ) ) THEN 621 zsurfmsk(:,:,1) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 622 DO jk = 2, jpk 623 zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) 657 !cbr ????????????? 658 !zsurfmsk(:,:,1) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 659 !DO jk = 2, jpk 660 ! zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) 661 !ENDDO 662 DO jk = 1, jpk 663 zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 624 664 ENDDO 625 665 ELSE 626 zsurfmsk(:,:,1) = p_e12(:,:) * p_mask(:,:,1) 627 DO jk = 2, jpk 628 zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk-1) 666 !zsurfmsk(:,:,1) = p_e12(:,:) * p_mask(:,:,1) 667 !DO jk = 2, jpk 668 ! zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk-1) 669 !ENDDO 670 DO jk = 1, jpk 671 zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk) 629 672 ENDDO 630 673 ENDIF … … 712 755 & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) 713 756 714 zsfcrs = zsurfmsk(ji ,jj ,jk) &715 & + zsurfmsk(ji+1,jj ,jk) &716 & + zsurfmsk(ji+2,jj ,jk)717 718 IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs719 ELSE ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs720 ENDIF757 !zsfcrs = zsurfmsk(ji ,jj ,jk) & 758 ! & + zsurfmsk(ji+1,jj ,jk) & 759 ! & + zsurfmsk(ji+2,jj ,jk) 760 761 !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs 762 !ELSE ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 763 !ENDIF 721 764 ENDIF 722 765 ELSE … … 726 769 & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 727 770 ! 728 zsfcrs = zsurfmsk(ji ,ijje,jk) & 729 & + zsurfmsk(ji+1,ijje,jk) & 730 & + zsurfmsk(ji+2,ijje,jk) 731 732 IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs 733 ELSE ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 734 ENDIF 771 !zsfcrs = zsurfmsk(ji ,ijje,jk) & 772 ! & + zsurfmsk(ji+1,ijje,jk) & 773 ! & + zsurfmsk(ji+2,ijje,jk) 774 775 p_fld_crs(ii,2,jk) = zflcrs 776 !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs 777 !ELSE ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 778 !ENDIF 735 779 736 780 ENDIF … … 746 790 & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 747 791 ! 748 zsfcrs = zsurfmsk(ji ,ijje,jk) & 749 & + zsurfmsk(ji+1,ijje,jk) & 750 & + zsurfmsk(ji+2,ijje,jk) 751 752 IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,ij,jk) = zflcrs 753 ELSE ; p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 754 ENDIF 792 !zsfcrs = zsurfmsk(ji ,ijje,jk) & 793 ! & + zsurfmsk(ji+1,ijje,jk) & 794 ! & + zsurfmsk(ji+2,ijje,jk) 795 796 p_fld_crs(ii,ij,jk) = zflcrs 797 !cbr1 798 !iji=117 ; ijj=210 799 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 800 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 801 !WRITE(narea+5000,*)"OPE V =======> " 802 !WRITE(narea+5000,*)ii,ij,jk 803 !WRITE(narea+5000,*)ji,jj,ijje 804 !WRITE(narea+5000,*)p_fld(ji ,ijje,jk) 805 !WRITE(narea+5000,*)p_fld(ji+1,ijje,jk) 806 !WRITE(narea+5000,*)p_fld(ji+2,ijje,jk) 807 !WRITE(narea+5000,*)zflcrs 808 !ENDIF 809 810 !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,ij,jk) = zflcrs 811 !ELSE ; p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 812 !ENDIF 755 813 ! 814 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )WRITE(narea+5000,*)" p_fld_crs(ii,ij,jk) = ", p_fld_crs(ii,ij,jk) 756 815 ENDDO 757 816 ENDDO … … 809 868 ENDIF 810 869 870 !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) end SUM = ",p_fld(17,5,74) 811 871 CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk ) 812 872 … … 987 1047 CALL wrk_alloc( jpi, jpj, jpk, zmask ) 988 1048 989 SELECT CASE ( cd_type ) 990 CASE( 'W' ) 991 zmask(:,:,1) = p_mask(:,:,1) 992 DO jk = 2, jpk 993 zmask(:,:,jk) = p_mask(:,:,jk-1) 994 ENDDO 995 CASE ( 'T' ) 1049 !SELECT CASE ( cd_type ) 1050 ! CASE( 'W' ) 1051 ! !cbr ????????????????????????????? 1052 ! zmask(:,:,1) = p_mask(:,:,1) 1053 ! DO jk = 2, jpk 1054 ! zmask(:,:,jk) = p_mask(:,:,jk-1) 1055 ! ENDDO 1056 ! CASE ( 'T' ) 996 1057 DO jk = 1, jpk 997 1058 zmask(:,:,jk) = p_mask(:,:,jk) 998 1059 ENDDO 999 END SELECT1060 !END SELECT 1000 1061 1001 1062 SELECT CASE ( cd_type ) … … 1157 1218 END SELECT 1158 1219 ! 1220 !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) avt lbc = ",p_fld(17,5,74) 1159 1221 CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) 1222 !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) apr lbc = ",p_fld(17,5,74) 1160 1223 ! 1161 1224 END SUBROUTINE crs_dom_ope_3d … … 1205 1268 1206 1269 !!---------------------------------------------------------------- 1207 1270 1208 1271 p_fld_crs(:,:) = 0.0 1209 1272 … … 1702 1765 INTEGER :: ijie, ijje, ii, ij, je_2 1703 1766 REAL(wp) :: ze3crs 1704 REAL(wp), DIMENSION(:,:,:), POINTER :: zmask, zsurf1767 !REAL(wp), DIMENSION(:,:,:), POINTER :: zmask, zsurf 1705 1768 1706 1769 !!---------------------------------------------------------------- … … 1710 1773 1711 1774 1712 CALL wrk_alloc( jpi, jpj, jpk, zmask, zsurf )1775 !CALL wrk_alloc( jpi, jpj, jpk, zmask, zsurf ) 1713 1776 1714 1777 SELECT CASE ( cd_type ) 1715 CASE( 'W' ) 1716 zmask(:,:,1) = p_mask(:,:,1) 1717 DO jk = 2, jpk 1718 zmask(:,:,jk) = p_mask(:,:,jk-1) 1719 ENDDO 1720 CASE DEFAULT 1721 DO jk = 1, jpk 1722 zmask(:,:,jk) = p_mask(:,:,jk) 1723 ENDDO 1778 1779 CASE ('T') 1780 1781 DO jk = 1 , jpk 1782 DO ji = nistr, niend, nn_factx 1783 1784 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1785 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 1786 1787 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1788 1789 jj = mje_crs(2) 1790 1791 1792 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 1793 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 1794 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk)) 1795 1796 p_e3_max_crs(ii,2,jk) = ze3crs 1797 1798 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 1799 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 1800 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) 1801 1802 1803 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1804 ENDIF 1805 ELSE 1806 jj = mjs_crs(2) 1807 1808 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 1809 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 1810 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 1811 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk), & 1812 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk), & 1813 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 1814 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 1815 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 1816 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 1817 1818 p_e3_max_crs(ii,2,jk) = ze3crs 1819 1820 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 1821 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 1822 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 1823 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk) + & 1824 & 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) + & 1825 & 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) + & 1826 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 1827 & 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) + & 1828 & 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) 1829 1830 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1831 ENDIF 1832 1833 DO jj = njstr, njend, nn_facty 1834 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1835 ij = ( jj - njstr ) * rfacty_r + 3 1836 ijje = mje_crs(ij) 1837 ijie = mie_crs(ii) 1838 ! 1839 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 1840 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 1841 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 1842 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk), & 1843 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk), & 1844 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 1845 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 1846 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 1847 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 1848 1849 p_e3_max_crs(ii,ij,jk) = ze3crs 1850 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 1851 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 1852 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 1853 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk) + & 1854 & 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) + & 1855 & 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) + & 1856 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 1857 & 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) + & 1858 & 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) 1859 1860 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1861 1862 ENDDO 1863 ENDDO 1864 ENDDO 1865 1866 CASE ('U') 1867 1868 DO jk = 1 , jpk 1869 DO ji = nistr, niend, nn_factx 1870 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1871 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 1872 1873 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1874 1875 jj = mje_crs(2) 1876 1877 1878 ze3crs = p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk) 1879 1880 p_e3_max_crs(ii,2,jk) = ze3crs 1881 1882 ze3crs = p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) 1883 1884 1885 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1886 ENDIF 1887 ELSE 1888 jj = mjs_crs(2) 1889 1890 ze3crs = MAX( p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 1891 p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 1892 p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 1893 1894 p_e3_max_crs(ii,2,jk) = ze3crs 1895 1896 ze3crs = p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 1897 & 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) + & 1898 & 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) 1899 1900 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1901 ENDIF 1902 DO jj = njstr, njend, nn_facty 1903 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1904 ij = ( jj - njstr ) * rfacty_r + 3 1905 ijje = mje_crs(ij) 1906 ijie = mie_crs(ii) 1907 ! 1908 ze3crs = MAX( p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 1909 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 1910 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 1911 1912 p_e3_max_crs(ii,ij,jk) = ze3crs 1913 1914 ze3crs = p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 1915 & 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) + & 1916 & 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) 1917 1918 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1919 1920 ENDDO 1921 ENDDO 1922 ENDDO 1923 1924 CASE ('V') 1925 DO jk = 1 , jpk 1926 DO ji = nistr, niend, nn_factx 1927 1928 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1929 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 1930 1931 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1932 1933 jj = mje_crs(2) 1934 1935 1936 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 1937 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 1938 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk)) 1939 1940 p_e3_max_crs(ii,2,jk) = ze3crs 1941 1942 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 1943 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 1944 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) 1945 1946 1947 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1948 ENDIF 1949 ELSE 1950 jj = mjs_crs(2) 1951 1952 ze3crs = MAX( p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 1953 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 1954 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 1955 1956 p_e3_max_crs(ii,2,jk) = ze3crs 1957 1958 ze3crs = p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 1959 & 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) + & 1960 & 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) 1961 1962 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1963 ENDIF 1964 1965 DO jj = njstr, njend, nn_facty 1966 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1967 ij = ( jj - njstr ) * rfacty_r + 3 1968 ijje = mje_crs(ij) 1969 ijie = mie_crs(ii) 1970 ! 1971 ze3crs = MAX( p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 1972 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 1973 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 1974 1975 p_e3_max_crs(ii,ij,jk) = ze3crs 1976 1977 ze3crs = p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 1978 & 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) + & 1979 & 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) 1980 1981 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1982 1983 ENDDO 1984 ENDDO 1985 ENDDO 1986 CASE ('W') 1987 1988 DO jk = 2 , jpk 1989 DO ji = nistr, niend, nn_factx 1990 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1991 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 1992 1993 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1994 1995 jj = mje_crs(2) 1996 1997 1998 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 1999 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 2000 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1)) 2001 2002 p_e3_max_crs(ii,2,jk) = ze3crs 2003 2004 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk-1) + & 2005 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) + & 2006 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) 2007 2008 2009 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2010 ENDIF 2011 ELSE 2012 jj = mjs_crs(2) 2013 2014 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 2015 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 2016 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1), & 2017 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1), & 2018 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1), & 2019 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1), & 2020 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1), & 2021 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1), & 2022 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 2023 2024 p_e3_max_crs(ii,2,jk) = ze3crs 2025 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk-1) + & 2026 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) + & 2027 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) + & 2028 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk-1) + & 2029 & 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) + & 2030 & 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) + & 2031 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk-1) + & 2032 & 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) + & 2033 & 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) 2034 2035 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 2036 ENDIF 2037 2038 2039 DO jj = njstr, njend, nn_facty 2040 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 2041 ij = ( jj - njstr ) * rfacty_r + 3 2042 ijje = mje_crs(ij) 2043 ijie = mie_crs(ii) 2044 ! 2045 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 2046 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 2047 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1), & 2048 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1), & 2049 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1), & 2050 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1), & 2051 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1), & 2052 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1), & 2053 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 2054 2055 p_e3_max_crs(ii,ij,jk) = ze3crs 2056 2057 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk-1) + & 2058 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) + & 2059 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) + & 2060 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk-1) + & 2061 & 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) + & 2062 & 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) + & 2063 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk-1) + & 2064 & 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) + & 2065 & 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) 2066 2067 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 2068 2069 ENDDO 2070 ENDDO 2071 ENDDO 2072 DO ji = nistr, niend, nn_factx 2073 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2074 IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN !!cc bande du sud style ORCA2 2075 2076 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2077 2078 jj = mje_crs(2) 2079 2080 ze3crs = MAX( p_e3(ji ,jj ,1) * p_mask(ji ,jj ,1), & 2081 & p_e3(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 2082 & p_e3(ji+2,jj ,1) * p_mask(ji+2,jj ,1)) 2083 2084 p_e3_max_crs(ii,2,1) = ze3crs 2085 2086 ze3crs = p_e3(ji ,jj ,1) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,1) + & 2087 & p_e3(ji+1,jj ,1) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,1) + & 2088 & p_e3(ji+2,jj ,1) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,1) 2089 2090 p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1) 2091 ENDIF 2092 ELSE 2093 jj = mjs_crs(2) 2094 2095 ze3crs = MAX( p_e3(ji ,jj ,1) * p_mask(ji ,jj ,1), & 2096 & p_e3(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 2097 & p_e3(ji+2,jj ,1) * p_mask(ji+2,jj ,1), & 2098 & p_e3(ji ,jj+1,1) * p_mask(ji ,jj+1,1), & 2099 & p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1), & 2100 & p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1), & 2101 & p_e3(ji ,jj+2,1) * p_mask(ji ,jj+2,1), & 2102 & p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1), & 2103 & p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 2104 2105 p_e3_max_crs(ii,2,1) = ze3crs 2106 ze3crs = p_e3(ji ,jj ,1) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,1) + & 2107 & p_e3(ji+1,jj ,1) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,1) + & 2108 & p_e3(ji+2,jj ,1) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,1) + & 2109 & p_e3(ji ,jj+1,1) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,1) + & 2110 & 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) + & 2111 & 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) + & 2112 & p_e3(ji ,jj+2,1) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,1) + & 2113 & 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) + & 2114 & 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) 2115 2116 p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1) 2117 2118 ENDIF 2119 DO jj = njstr, njend, nn_facty 2120 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 2121 ij = ( jj - njstr ) * rfacty_r + 3 2122 ijje = mje_crs(ij) 2123 ijie = mie_crs(ii) 2124 ! 2125 ze3crs = MAX( p_e3(ji ,jj ,1) * p_mask(ji ,jj ,1), & 2126 & p_e3(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 2127 & p_e3(ji+2,jj ,1) * p_mask(ji+2,jj ,1), & 2128 & p_e3(ji ,jj+1,1) * p_mask(ji ,jj+1,1), & 2129 & p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1), & 2130 & p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1), & 2131 & p_e3(ji ,jj+2,1) * p_mask(ji ,jj+2,1), & 2132 & p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1), & 2133 & p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 2134 2135 p_e3_max_crs(ii,ij,1) = ze3crs 2136 2137 ze3crs = p_e3(ji ,jj ,1) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,1) + & 2138 & p_e3(ji+1,jj ,1) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,1) + & 2139 & p_e3(ji+2,jj ,1) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,1) + & 2140 & p_e3(ji ,jj+1,1) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,1) + & 2141 & 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) + & 2142 & 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) + & 2143 & p_e3(ji ,jj+2,1) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,1) + & 2144 & 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) + & 2145 & 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) 2146 2147 p_e3_crs(ii,ij,1) = ze3crs / p_sfc_crs(ii,ij,1) 2148 2149 ENDDO 2150 ENDDO 2151 ! 1724 2152 END SELECT 1725 2153 1726 DO jk = 1, jpk 1727 zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 1728 ENDDO 1729 1730 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1731 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1732 je_2 = mje_crs(2) 1733 DO jk = 1 , jpk 1734 DO ji = nistr, niend, nn_factx 1735 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1736 ze3crs = zsurf(ji ,je_2,jk) * zmask(ji ,je_2,jk) & 1737 & + zsurf(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & 1738 & + zsurf(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 1739 1740 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1741 ! 1742 ze3crs = MAX( p_e3(ji ,je_2,jk) * zmask(ji ,je_2,jk), & 1743 & p_e3(ji+1,je_2,jk) * zmask(ji+1,je_2,jk), & 1744 & p_e3(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) ) 1745 ! 1746 p_e3_max_crs(ii,2,jk) = ze3crs 1747 ENDDO 1748 ENDDO 1749 ENDIF 1750 ELSE 1751 je_2 = mjs_crs(2) 1752 DO jk = 1 , jpk 1753 DO ji = nistr, niend, nn_factx 1754 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1755 ze3crs = zsurf(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & 1756 & + zsurf(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & 1757 & + zsurf(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & 1758 & + zsurf(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & 1759 & + zsurf(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & 1760 & + zsurf(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & 1761 & + zsurf(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & 1762 & + zsurf(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & 1763 & + zsurf(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) 1764 1765 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1766 ! 1767 ze3crs = MAX( p_e3(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk), & 1768 & p_e3(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk), & 1769 & p_e3(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk), & 1770 & p_e3(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk), & 1771 & p_e3(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk), & 1772 & p_e3(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk), & 1773 & p_e3(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk), & 1774 & p_e3(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk), & 1775 & p_e3(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) ) 1776 1777 p_e3_max_crs(ii,2,jk) = ze3crs 1778 ENDDO 1779 ENDDO 1780 ENDIF 1781 DO jk = 1 , jpk 1782 DO jj = njstr, njend, nn_facty 1783 DO ji = nistr, niend, nn_factx 1784 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1785 ij = ( jj - njstr ) * rfacty_r + 3 1786 ze3crs = zsurf(ji ,jj ,jk) * zmask(ji ,jj ,jk) & 1787 & + zsurf(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & 1788 & + zsurf(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & 1789 & + zsurf(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & 1790 & + zsurf(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & 1791 & + zsurf(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & 1792 & + zsurf(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & 1793 & + zsurf(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & 1794 & + zsurf(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) 1795 1796 !cbr 1797 !p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1798 IF( p_sfc_crs(ii,ij,jk) == 0.d0 )WRITE(narea+200,*)"crs_dom_e30 ",ii,ij,jk,p_sfc_crs(ii,ij,jk) ; call flush(narea+200) 1799 IF( p_sfc_crs(ii,ij,jk) .NE. 0.d0 )THEN ; p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1800 ELSE ; p_e3_crs(ii,ij,jk) =0.d0 1801 ENDIF 1802 ! 1803 ze3crs = MAX( p_e3(ji ,jj ,jk) * zmask(ji ,jj ,jk), & 1804 & p_e3(ji+1,jj ,jk) * zmask(ji+1,jj ,jk), & 1805 & p_e3(ji+2,jj ,jk) * zmask(ji+2,jj ,jk), & 1806 & p_e3(ji ,jj+1,jk) * zmask(ji ,jj+1,jk), & 1807 & p_e3(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk), & 1808 & p_e3(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk), & 1809 & p_e3(ji ,jj+2,jk) * zmask(ji ,jj+2,jk), & 1810 & p_e3(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk), & 1811 & p_e3(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) ) 1812 1813 p_e3_max_crs(ii,ij,jk) = ze3crs 1814 ENDDO 1815 ENDDO 1816 ENDDO 1817 1818 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pval=1.0 ) 1819 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 2154 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 2155 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pval=1.0 ) 1820 2156 ! 1821 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zmask )2157 !CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zmask ) 1822 2158 ! 1823 2159 END SUBROUTINE crs_dom_e3 … … 1836 2172 INTEGER :: ji, jj, jk ! dummy loop indices 1837 2173 INTEGER :: ii, ij, je_2 2174 INTEGER :: iji,ijj 1838 2175 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk 1839 2176 !!---------------------------------------------------------------- 1840 2177 ! Initialize 1841 2178 p_surf_crs(:,:,:)=0._wp 2179 p_surf_crs_msk(:,:,:)=0._wp 1842 2180 1843 2181 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) … … 1849 2187 zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 1850 2188 ENDDO 1851 zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 1852 DO jk = 2, jpk 1853 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 2189 !zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 2190 !cbr DO jk = 2, jpk 2191 DO jk = 1, jpk 2192 !cbr zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 2193 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 1854 2194 ENDDO 1855 2195 … … 1878 2218 ENDDO 1879 2219 END SELECT 2220 2221 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) 2222 2223 SELECT CASE ( cd_type ) 2224 2225 CASE ('W') 1880 2226 1881 2227 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 … … 1916 2262 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1917 2263 ij = ( jj - njstr ) * rfacty_r + 3 1918 IF( jk==1 .AND. ii==2 .AND. ij==18 )THEN1919 WRITE(narea+200,*)"crs_dom_sfc ",zsurf(ji,jj ,jk) , zsurf(ji+1,jj ,jk) , zsurf(ji+2,jj ,jk) &1920 & , zsurf(ji,jj+1,jk) , zsurf(ji+1,jj+1,jk) , zsurf(ji+2,jj+1,jk) &1921 & , zsurf(ji,jj+2,jk) , zsurf(ji+1,jj+2,jk) , zsurf(ji+2,jj+2,jk)1922 call flush(narea+200)1923 ENDIF1924 2264 ! 1925 2265 p_surf_crs (ii,ij,jk) = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 1926 2266 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 1927 2267 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 1928 IF( jk==1 .AND. ii==2 .AND. ij==18 )WRITE(narea+200,*)"crs_dom_sfc ",p_surf_crs (ii,ij,jk) ; call flush(narea+200)1929 2268 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj ,jk) + zsurfmsk(ji+1,jj ,jk) + zsurfmsk(ji+2,jj ,jk) & 1930 2269 & + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk) & 1931 2270 & + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 2271 2272 !cbr 2273 iji=117 ; ijj=211 2274 iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 2275 IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 2276 WRITE(narea+5000,*)"SFC W =======> " 2277 WRITE(narea+5000,*)ii,ij,jk 2278 WRITE(narea+5000,*)ji,jj 2279 WRITE(narea+5000,*)zsurfmsk(ji,jj ,jk) , zsurfmsk(ji+1,jj ,jk) , zsurfmsk(ji+2,jj ,jk) 2280 WRITE(narea+5000,*)zsurfmsk(ji,jj+1,jk) , zsurfmsk(ji+1,jj+1,jk) , zsurfmsk(ji+2,jj+1,jk) 2281 WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk) , zsurfmsk(ji+1,jj+2,jk) , zsurfmsk(ji+2,jj+2,jk) 2282 WRITE(narea+5000,*) p_surf_crs (ii,ij,jk), p_surf_crs_msk(ii,ij,jk) 2283 ENDIF 2284 2285 1932 2286 ENDDO 1933 2287 ENDDO 1934 2288 ENDDO 1935 WRITE(narea+200,*)"crs_dom_sfc end ", p_surf_crs (2,18,1) 2289 2290 CASE ('U') 2291 2292 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 2293 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2294 je_2 = mje_crs(2) 2295 DO jk = 1, jpk 2296 DO ji = nistr, niend, nn_factx 2297 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2298 ! 2299 p_surf_crs (ii,2,jk) = zsurf(ji+2,je_2 ,jk) 2300 ! 2301 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji+2,je_2,jk) 2302 ! 2303 ENDDO 2304 ENDDO 2305 ENDIF 2306 ELSE 2307 je_2 = mjs_crs(2) 2308 DO jk = 1, jpk 2309 DO ji = nistr, niend, nn_factx 2310 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2311 ! 2312 p_surf_crs (ii,2,jk) = zsurf(ji+2,je_2 ,jk) & 2313 & + zsurf(ji+2,je_2+1,jk) & 2314 & + zsurf(ji+2,je_2+2,jk) 2315 2316 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji+2,je_2 ,jk) & 2317 & + zsurfmsk(ji+2,je_2+1,jk) & 2318 & + zsurfmsk(ji+2,je_2+2,jk) 2319 ENDDO 2320 ENDDO 2321 ENDIF 2322 2323 DO jk = 1, jpk 2324 DO jj = njstr, njend, nn_facty 2325 DO ji = nistr, niend, nn_factx 2326 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2327 ij = ( jj - njstr ) * rfacty_r + 3 2328 ! 2329 p_surf_crs (ii,ij,jk) = zsurf(ji+2,jj ,jk) & 2330 & + zsurf(ji+2,jj+1,jk) & 2331 & + zsurf(ji+2,jj+2,jk) 2332 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji+2,jj ,jk) & 2333 & + zsurfmsk(ji+2,jj+1,jk) & 2334 & + zsurfmsk(ji+2,jj+2,jk) 2335 !cbr 2336 !iji=117 ; ijj=211 2337 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 2338 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 2339 !WRITE(narea+5000,*)"SFC U =======> " 2340 !WRITE(narea+5000,*)ii,ij,jk 2341 !WRITE(narea+5000,*)ji,jj 2342 !WRITE(narea+5000,*)mis_crs(2),rfactx_r , ( ji - 1 - mis_crs(2) ) * rfactx_r 2343 !WRITE(narea+5000,*)zsurf(ji+2,jj ,jk),zsurf(ji+2,jj+1,jk),zsurf(ji+2,jj+2,jk) 2344 !WRITE(narea+5000,*)zsurfmsk(ji+2,jj ,jk),zsurfmsk(ji+2,jj+1,jk),zsurfmsk(ji+2,jj+2,jk) 2345 !WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk) 2346 !ENDIF 2347 !iji=116 ; ijj=211 2348 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 2349 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 2350 !WRITE(narea+5000,*)"SFC U =======> " 2351 !WRITE(narea+5000,*)ii,ij,jk 2352 !WRITE(narea+5000,*)ji,jj 2353 !WRITE(narea+5000,*)zsurf(ji+2,jj ,jk),zsurf(ji+2,jj+1,jk),zsurf(ji+2,jj+2,jk) 2354 !WRITE(narea+5000,*)zsurfmsk(ji+2,jj ,jk),zsurfmsk(ji+2,jj+1,jk),zsurfmsk(ji+2,jj+2,jk) 2355 !WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk) 2356 !ENDIF 2357 ENDDO 2358 ENDDO 2359 ENDDO 2360 2361 CASE ('V') 2362 2363 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 2364 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 2365 je_2 = mje_crs(2) 2366 DO jk = 1, jpk 2367 DO ji = nistr, niend, nn_factx 2368 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2369 ! 2370 p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) 2371 ! 2372 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 2373 ! 2374 ENDDO 2375 ENDDO 2376 ENDIF 2377 ELSE 2378 je_2 = mjs_crs(2) 2379 DO jk = 1, jpk 2380 DO ji = nistr, niend, nn_factx 2381 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2382 ! 2383 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) 2384 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) 2385 ENDDO 2386 ENDDO 2387 ENDIF 2388 2389 DO jk = 1, jpk 2390 DO jj = njstr, njend, nn_facty 2391 DO ji = nistr, niend, nn_factx 2392 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 2393 ij = ( jj - njstr ) * rfacty_r + 3 2394 ! 2395 p_surf_crs (ii,ij,jk) = zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 2396 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 2397 iji=117 ; ijj=210 2398 iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 2399 IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 2400 WRITE(narea+5000,*)"SFC V =======> " 2401 WRITE(narea+5000,*)ii,ij,jk 2402 WRITE(narea+5000,*)ji,jj 2403 WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk),zsurfmsk(ji+1,jj+2,jk),zsurfmsk(ji+2,jj+2,jk) 2404 WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk) 2405 ENDIF 2406 ENDDO 2407 ENDDO 2408 ENDDO 2409 2410 END SELECT 2411 DO jk=1,jpk 2412 DO ji=1,jpi_crs 2413 DO jj=1,jpj_crs 2414 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) 2415 ENDDO 2416 ENDDO 2417 ENDDO 1936 2418 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, pval=1.0 ) 1937 2419 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 1938 WRITE(narea+200,*)"crs_dom_sfc end ", p_surf_crs (2,18,1)1939 2420 1940 2421 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90
r5010 r5105 66 66 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt_crs, zs_crs ! 67 67 REAL(wp) :: z2dcrsu, z2dcrsv 68 REAL(wp) :: zmin,zmax 69 INTEGER :: i,j,ijis,ijie,ijjs,ijje 70 REAL(wp) :: zw,zwp1,zum1,zu,zvm1,zv,zsnm,zsm,z 71 INTEGER :: iji,ijj 68 72 !! 69 73 !!---------------------------------------------------------------------- 70 74 ! 75 !IF(narea==267)WRITE(narea+5000,*)"========================================> crsfldt ",kt 71 76 72 77 IF( nn_timing == 1 ) CALL timing_start('crs_fld') … … 91 96 wn_crs (:,:,: ) = 0._wp ! w 92 97 avt_crs (:,:,: ) = 0._wp ! avt 98 hdivb_crs(:,:,: ) = 0._wp ! hdiv 93 99 hdivn_crs(:,:,: ) = 0._wp ! hdiv 94 100 rke_crs (:,:,: ) = 0._wp ! rke … … 110 116 111 117 ! Temperature 118 zt(:,:,:) = tsb(:,:,:,jp_tem) ; zt_crs(:,:,:) = 0._wp 119 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 120 tsb_crs(:,:,:,jp_tem) = zt_crs(:,:,:) 112 121 zt(:,:,:) = tsn(:,:,:,jp_tem) ; zt_crs(:,:,:) = 0._wp 113 122 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) … … 119 128 120 129 ! Salinity 130 zs(:,:,:) = tsb(:,:,:,jp_sal) ; zs_crs(:,:,:) = 0._wp 131 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 132 tsb_crs(:,:,:,jp_sal) = zt_crs(:,:,:) 121 133 zs(:,:,:) = tsn(:,:,:,jp_sal) ; zs_crs(:,:,:) = 0._wp 122 134 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) … … 127 139 128 140 ! U-velocity 141 CALL crs_dom_ope( ub, 'SUM', 'U', umask, ub_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 129 142 CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 143 !cbr 144 ub_crs(:,:,:) = ub_crs(:,:,:)*umask_crs(:,:,:) 145 un_crs(:,:,:) = un_crs(:,:,:)*umask_crs(:,:,:) 130 146 ! 131 147 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 146 162 147 163 ! V-velocity 164 !IF(narea==267)WRITE(narea+5000,*)"deg vb_crs" 165 CALL crs_dom_ope( vb, 'SUM', 'V', vmask, vb_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 166 !IF(narea==267)WRITE(narea+5000,*)"deg vn_crs" 148 167 CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 168 !IF(narea==267)WRITE(narea+5000,*)"1 vn_crs(17,5,74) = ",vn_crs(17,5,74),vmask_crs(17,5,74),vn(46,13,74),vn(47,13,74),vn(48,13,74) 169 vb_crs(:,:,:) = vb_crs(:,:,:)*vmask_crs(:,:,:) 170 vn_crs(:,:,:) = vn_crs(:,:,:)*vmask_crs(:,:,:) 171 !IF(narea==267)WRITE(narea+5000,*)"2 vn_crs(17,5,74) = ",vn_crs(17,5,74),vmask_crs(17,5,74),vn(46,13,74),vn(47,13,74),vn(48,13,74) 149 172 ! 150 173 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 174 197 DO jj = 2, jpj_crsm1 175 198 IF( tmask_crs(ji,jj,jk ) > 0 ) THEN 199 !z2dcrsu = ( un_crs(ji ,jj ,jk) * crs_surfu_wgt(ji ,jj ,jk) ) & 200 ! & - ( un_crs(ji-1,jj ,jk) * crs_surfu_wgt(ji-1,jj ,jk) ) 201 !z2dcrsv = ( vn_crs(ji ,jj ,jk) * crs_surfv_wgt(ji ,jj ,jk) ) & 202 ! & - ( vn_crs(ji ,jj-1,jk) * crs_surfv_wgt(ji ,jj-1,jk) ) 203 ! 204 !IF( crs_volt_wgt(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / crs_volt_wgt(ji,jj,jk) 176 205 z2dcrsu = ( un_crs(ji ,jj ,jk) * e2e3u_msk(ji ,jj ,jk) ) & 177 206 & - ( un_crs(ji-1,jj ,jk) * e2e3u_msk(ji-1,jj ,jk) ) … … 179 208 & - ( vn_crs(ji ,jj-1,jk) * e1e3v_msk(ji ,jj-1,jk) ) 180 209 ! 181 IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / ocean_volume_crs_t(ji,jj,jk) 210 !cbr 211 ! 212 !bug1: il manquait le facvol_t(ji,jj,jk) ds la division ; ca creait des grosses erreurs de Wcrs ( vu en recalculant la divergence 3D ) 213 !bug2: mm test que bug1: on n'obtient tjs pas zero 214 !on a la div calculée via ocean_volume_crs_t puis w via e3t_crs ; or ,e1t_crs(ji,jj)*e2t_crs(ji,jj)*e3t_crs(ji,jj,jk) NE ocean_volume_crs_t*crs_volt_wgt(ji,jj,jk) 215 !exp (117,211,74) : e1*e2*e3=235206030060.005 / ocean_volume_crs_t * facvol = 235205585307.810 216 ! e1*e2*e3-cean_volume_crs_t * facvol/(cean_volume_crs_t * facvol) ~1.e-6) 217 !IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / (facvol_t(ji,jj,jk)*ocean_volume_crs_t(ji,jj,jk)) 218 !IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / (e1t_crs(ji,jj)*e2t_crs(ji,jj)*e3t_crs(ji,jj,jk)) 219 IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) 220 221 !iji=117 ; ijj=211 222 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 223 !IF( ji==iji .AND. jj==ijj )THEN 224 !WRITE(narea+5000,*)"hdivn_crs =======> " 225 !WRITE(narea+5000,*) "u" ,jk,un_crs(ji ,jj ,jk) ,e2e3u_msk(ji ,jj ,jk),un_crs(ji ,jj ,jk)*e2e3u_msk(ji ,jj ,jk) 226 !WRITE(narea+5000,*) "um1",jk,un_crs(ji-1,jj ,jk) , e2e3u_msk(ji-1,jj ,jk),un_crs(ji-1,jj ,jk) * e2e3u_msk(ji-1,jj ,jk) 227 !WRITE(narea+5000,*) "v",jk,vn_crs(ji ,jj ,jk) , e1e3v_msk(ji ,jj ,jk),vn_crs(ji ,jj ,jk) * e1e3v_msk(ji ,jj ,jk) 228 !WRITE(narea+5000,*) "vm1",jk,vn_crs(ji ,jj-1,jk) , e1e3v_msk(ji ,jj-1,jk),vn_crs(ji ,jj-1,jk) * e1e3v_msk(ji ,jj-1,jk) 229 !WRITE(narea+5000,*) "t1 ",jk,z2dcrsu,z2dcrsv, z2dcrsu + z2dcrsv,hdivn_crs(ji,jj,jk) 230 !WRITE(narea+5000,*) "t2 ",jk,e1t_crs(ji,jj),e2t_crs(ji,jj),e3t_crs(ji,jj,jk),e1t_crs(ji,jj)*e2t_crs(ji,jj)*e3t_crs(ji,jj,jk) 231 !WRITE(narea+5000,*) "t3 ",jk,ocean_volume_crs_t(ji,jj,jk),facvol_t(ji,jj,jk),facvol_t(ji,jj,jk)*ocean_volume_crs_t(ji,jj,jk) 232 !WRITE(narea+5000,*) "t4 ",jk, ( z2dcrsu + z2dcrsv ) / (facvol_t(ji,jj,jk)*ocean_volume_crs_t(ji,jj,jk)) 233 !WRITE(narea+5000,*) "t5 ",jk, ( z2dcrsu + z2dcrsv ) / (e1t_crs(ji,jj)*e2t_crs(ji,jj)*e3t_crs(ji,jj,jk)) 234 !ENDIF 235 236 237 !IF( crs_volt_wgt(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / crs_volt_wgt(ji,jj,jk) 238 z2dcrsu = ( ub_crs(ji ,jj ,jk) * e2e3u_msk(ji ,jj ,jk) ) & 239 & - ( ub_crs(ji-1,jj ,jk) * e2e3u_msk(ji-1,jj ,jk) ) 240 z2dcrsv = ( vb_crs(ji ,jj ,jk) * e1e3v_msk(ji ,jj ,jk) ) & 241 & - ( vb_crs(ji ,jj-1,jk) * e1e3v_msk(ji ,jj-1,jk) ) 242 ! 243 IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivb_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / (facvol_t(ji,jj,jk)*ocean_volume_crs_t(ji,jj,jk) ) 182 244 ENDIF 183 245 ENDDO … … 189 251 190 252 253 ! DO jk = 1, jpkm1 ! Interior value 254 ! DO jj = 1, jpj_crs 255 ! DO ji = 1, jpi_crs 256 ! IF( e3t_crs(ji,jj,jk) .NE. e3t_crs(ji,jj,jk) )WRITE(narea+200,*)"e3t_crs",e3t_crs(ji,jj,jk) ; call flush(narea+200) 257 ! IF( hdivn_crs(ji,jj,jk) .NE. hdivn_crs(ji,jj,jk) )WRITE(narea+200,*)"hdivn_crs",hdivn_crs(ji,jj,jk) ; call flush(narea+200) 258 ! END DO 259 ! END DO 260 ! END DO 261 191 262 ! W-velocity 192 263 IF( ln_crs_wn ) THEN 193 264 CALL crs_dom_ope( wn, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 ) 194 ! CALL crs_dom_ope( wn, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=zfse3w )195 265 ELSE 196 266 wn_crs(:,:,jpk) = 0._wp 197 267 DO jk = jpkm1, 1, -1 198 wn_crs(:,:,jk) = wn_crs(:,:,jk+1) - e3t_crs(:,:,jk) * hdivn_crs(:,:,jk) 268 !cbr wn_crs(:,:,jk) = wn_crs(:,:,jk+1) - e3t_crs(:,:,jk) * hdivn_crs(:,:,jk) 269 wn_crs(:,:,jk) = e1e2w_msk(:,:,jk+1)*wn_crs(:,:,jk+1) - hdivn_crs(:,:,jk) 270 WHERE( e1e2w_msk(:,:,jk) .NE. 0._wp ) wn_crs(:,:,jk) = wn_crs(:,:,jk) /e1e2w_msk(:,:,jk) 199 271 ENDDO 200 272 ENDIF 273 201 274 CALL iom_put( "woce", wn_crs ) ! vertical velocity 202 275 ! free memory … … 216 289 ! sbc fields 217 290 291 CALL crs_dom_ope( sshb , 'VOL', 'T', tmask, sshb_crs , p_e12=e1e2t, p_e3=zfse3t , psgn=1.0 ) 218 292 CALL crs_dom_ope( sshn , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=zfse3t , psgn=1.0 ) 293 CALL crs_dom_ope( ssha , 'VOL', 'T', tmask, ssha_crs , p_e12=e1e2t, p_e3=zfse3t , psgn=1.0 ) 219 294 CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0 ) 220 295 CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0 ) … … 224 299 CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 225 300 CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 301 CALL crs_dom_ope( fmmflx,'SUM', 'T', tmask, fmmflx_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 226 302 CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 227 303 CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) … … 237 313 CALL iom_put( "ice_cover", fr_i_crs ) ! ice cover output 238 314 315 !cbr 316 !IF(narea==267)WRITE(narea+5000,*)"vn_crs(17,5,74) = ",vn_crs(17,5,74) 317 !ji=117 ; jj=211 ; jk=74 318 !ji=ji-nimpp_crs+1 ; jj=jj-njmpp_crs+1 319 !IF( ji .GE. 2 .AND. ji .LE. jpi_crs-1 .AND. jj .GE. 2 .AND. jj .LE. jpj_crs-1 )THEN 320 !WRITE(narea+5000,*)"=======> kt ",kt 321 !WRITE(narea+5000,*)ji,jj,glamt(ji,jj),gphit(ji,jj) 322 !WRITE(narea+5000,*)"um1 crs ",umask_crs(ji-1,jj,jk),e2e3u_msk(ji-1,jj,jk),un_crs(ji-1,jj,jk),umask_crs(ji-1,jj,jk)*e2e3u_msk(ji-1,jj,jk)*un_crs(ji-1,jj,jk) 323 !WRITE(narea+5000,*)"u crs ",umask_crs(ji,jj,jk),e2e3u_msk(ji,jj,jk),un_crs(ji,jj,jk),umask_crs(ji,jj,jk)*e2e3u_msk(ji,jj,jk)*un_crs(ji,jj,jk) 324 !WRITE(narea+5000,*)"vm1 crs ",vmask_crs(ji,jj-1,jk),e1e3v_msk(ji,jj-1,jk),vn_crs(ji,jj-1,jk),vmask_crs(ji,jj-1,jk)*e1e3v_msk(ji,jj-1,jk)*vn_crs(ji,jj-1,jk) 325 !WRITE(narea+5000,*)"v crs ",vmask_crs(ji,jj,jk),e1e3v_msk(ji,jj,jk),vn_crs(ji,jj,jk),vmask_crs(ji,jj,jk)*e1e3v_msk(ji,jj,jk)*vn_crs(ji,jj,jk) 326 !WRITE(narea+5000,*)"wp1 crs ",tmask_crs(ji,jj,jk+1),e1e2w_msk(ji,jj,jk+1),wn_crs(ji,jj,jk+1),tmask_crs(ji,jj,jk+1)*e1e2w_msk(ji,jj,jk+1)*wn_crs(ji,jj,jk+1) 327 !WRITE(narea+5000,*)"w crs ",tmask_crs(ji,jj,jk),e1e2w_msk(ji,jj,jk),wn_crs(ji,jj,jk),tmask_crs(ji,jj,jk)*e1e2w_msk(ji,jj,jk)*wn_crs(ji,jj,jk) 328 !z = umask_crs(ji,jj,jk)*e2e3u_msk(ji,jj,jk)*un_crs(ji,jj,jk) - umask_crs(ji-1,jj,jk)*e2e3u_msk(ji-1,jj,jk)*un_crs(ji-1,jj,jk) + & 329 ! vmask_crs(ji,jj,jk)*e1e3v_msk(ji,jj,jk)*vn_crs(ji,jj,jk) - vmask_crs(ji,jj-1,jk)*e1e3v_msk(ji,jj-1,jk)*vn_crs(ji,jj-1,jk) + & 330 ! tmask_crs(ji,jj,jk)*e1e2w_msk(ji,jj,jk)*wn_crs(ji,jj,jk) - tmask_crs(ji,jj,jk+1)*e1e2w_msk(ji,jj,jk+1)*wn_crs(ji,jj,jk+1) 331 !WRITE(narea+5000,*)"sum ",z 332 !ijie = mie_crs(ji) 333 !ijis = mis_crs(ji) 334 !ijje = mje_crs(jj) 335 !ijjs = mjs_crs(jj) 336 !DO i=ijis,ijie 337 ! DO j=ijjs,ijje 338 ! WRITE(narea+5000,*)"tmask",i,j,tmask(i,j,jk) 339 ! ENDDO 340 !ENDDO 341 342 !z=0._wp 343 !zsm=0._wp 344 !DO i=ijis,ijie 345 ! DO j=ijjs,ijje 346 ! WRITE(narea+5000,*)"w",i,j,tmask(i,j,jk),e1t(i,j),e2t(i,j),e1t(i,j)*e2t(i,j),wn(i,j,jk) 347 ! z=z+tmask(i,j,jk)*e1t(i,j)*e2t(i,j)*wn(i,j,jk) 348 ! zsm=zsm+tmask(i,j,jk)*e1t(i,j)*e2t(i,j) 349 ! ENDDO 350 !ENDDO 351 352 !zw=z 353 !WRITE(narea+5000,*)"w sum ",zsm,zw 354 !z=0._wp 355 !zsm=0._wp 356 !DO i=ijis,ijie 357 ! DO j=ijjs,ijje 358 ! WRITE(narea+5000,*)"wp1 ",i,j,tmask(i,j,jk+1),e1t(i,j),e2t(i,j),e1t(i,j)*e2t(i,j),wn(i,j,jk+1) 359 ! z=z+tmask(i,j,jk+1)*e1t(i,j)*e2t(i,j)*wn(i,j,jk+1) 360 ! zsm=zsm+tmask(i,j,jk+1)*e1t(i,j)*e2t(i,j) 361 ! ENDDO 362 !ENDDO 363 !zwp1=z 364 !WRITE(narea+5000,*)"wp1 sum ",zsm,zwp1 365 !z=0._wp 366 !zsm=0._wp 367 !i=ijis-1 368 !DO j=ijjs,ijje 369 ! WRITE(narea+5000,*)"um1",i,j,umask(i,j,jk),e2u(i,j),e3u_0(i,j,jk),e2u(i,j)*e3u_0(i,j,jk),un(i,j,jk) 370 ! z=z+e2u(i,j)*e3u_0(i,j,jk)*un(i,j,jk) 371 ! zsm=zsm+e2u(i,j)*e3u_0(i,j,jk)*umask(i,j,jk) 372 !ENDDO 373 !zum1=z 374 !WRITE(narea+5000,*)"um1 sum ",zsm,zum1 375 !z=0._wp 376 !zsm=0._wp 377 !i=ijie 378 !DO j=ijjs,ijje 379 ! WRITE(narea+5000,*)"u",i,j,umask(i,j,jk),e2u(i,j),e3u_0(i,j,jk),e2u(i,j)*e3u_0(i,j,jk),un(i,j,jk) 380 ! z=z+e2u(i,j)*e3u_0(i,j,jk)*un(i,j,jk) 381 ! zsm=zsm+e2u(i,j)*e3u_0(i,j,jk)*umask(i,j,jk) 382 !ENDDO 383 !zu=z 384 !WRITE(narea+5000,*)"u sum ",zsm,zu 385 !z=0._wp 386 !zsm=0._wp 387 !j=ijjs-1 388 !DO i=ijis,ijie 389 ! WRITE(narea+5000,*)"vm1",i,j,vmask(i,j,jk),e1v(i,j),e3v_0(i,j,jk),e1v(i,j)*e3v_0(i,j,jk),vn(i,j,jk) 390 ! z=z+e1v(i,j)*e3v_0(i,j,jk)*vn(i,j,jk) 391 ! zsm=zsm+e1v(i,j)*e3v_0(i,j,jk)*vmask(i,j,jk) 392 !ENDDO 393 !zvm1=z 394 !WRITE(narea+5000,*)"vm1 sum ",zsm,zvm1 395 !z=0._wp 396 !zsm=0._wp 397 !j=ijje 398 !DO i=ijis,ijie 399 ! WRITE(narea+5000,*)"v",i,j,vmask(i,j,jk),e1v(i,j),e3v_0(i,j,jk),e1v(i,j)*e3v_0(i,j,jk),vn(i,j,jk) 400 ! z=z+e1v(i,j)*e3v_0(i,j,jk)*vn(i,j,jk) 401 ! zsm=zsm+e1v(i,j)*e3v_0(i,j,jk)*vmask(i,j,jk) 402 !ENDDO 403 !zv=z 404 !WRITE(narea+5000,*)"v sum ",zv 405 !WRITE(narea+5000,*)"sum ",zw+zwp1+zum1+zu+zvm1+zv 406 !DO i=ijis,ijie 407 ! DO j=ijjs,ijje 408 ! WRITE(narea+5000,*)"msk",i,j,tmask(i,j,jk),umask(i,j,jk),vmask(i,j,jk) 409 ! WRITE(narea+5000,*)"vel",i,j,un(i,j,jk),vn(i,j,jk),wn(i,j,jk) 410 ! ENDDO 411 !ENDDO 412 413 !DO i=ijis,ijie 414 ! DO j=ijjs,ijje 415 ! z = un(i,j,jk)*e2u(i,j)*e3u_0(i,j,jk)*umask(i,j,jk) - un(i-1,j,jk)*e2u(i-1,j)*e3u_0(i-1,j,jk)*umask(i-1,j,jk) + & 416 ! vn(i,j,jk)*e1v(i,j)*e3v_0(i,j,jk)*vmask(i,j,jk) - vn(i,j-1,jk)*e1v(i,j-1)*e3v_0(i,j-1,jk)*vmask(i,j-1,jk) + & 417 ! wn(i,j,jk)*e2t(i,j)*e1t(i,j)*tmask(i,j,jk) - wn(i,j,jk+1)*e2t(i,j)*e1t(i,j)*tmask(i,j,jk+1) 418 ! WRITE(narea+5000,*)"div ",i,j,jk,z 419 ! ENDDO 420 !ENDDO 421 422 !ENDIF 423 424 425 239 426 ! free memory 240 427 CALL wrk_dealloc( jpi, jpj, jpk, zfse3t, zfse3w ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
r5007 r5105 68 68 INTEGER :: ierr ! allocation error status 69 69 INTEGER :: ios ! Local integer output status for namelist read 70 REAL(wp) :: zmin,zmax 70 71 REAL(wp), DIMENSION(:,:,:), POINTER :: zfse3t, zfse3u, zfse3v, zfse3w 71 72 72 NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, nn_msh_crs, nn_crs_kz, ln_crs_wn 73 NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, nn_msh_crs, nn_crs_kz, ln_crs_wn, ln_crs_top 73 74 !!---------------------------------------------------------------------- 74 75 ! … … 160 161 CALL crs_dom_hgr( e1f, e2f, 'F', e1f_crs, e2f_crs ) 161 162 163 WHERE(e1t_crs == 0._wp) e1t_crs=r_inf 164 WHERE(e1u_crs == 0._wp) e1u_crs=r_inf 165 WHERE(e1v_crs == 0._wp) e1v_crs=r_inf 166 WHERE(e1f_crs == 0._wp) e1f_crs=r_inf 167 WHERE(e2t_crs == 0._wp) e2t_crs=r_inf 168 WHERE(e2u_crs == 0._wp) e2u_crs=r_inf 169 WHERE(e2v_crs == 0._wp) e2v_crs=r_inf 170 WHERE(e2f_crs == 0._wp) e2f_crs=r_inf 171 162 172 e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:) 163 173 … … 169 179 CASE ( 0, 1, 4 ) ! mesh on the sphere 170 180 181 zmin=MINVAL(ABS(gphif_crs(:,:)));zmax=MAXVAL(ABS(gphif_crs(:,:)));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"gphif_crs",zmin,zmax 171 182 ff_crs(:,:) = 2. * omega * SIN( rad * gphif_crs(:,:) ) 172 183 … … 190 201 191 202 ! 3.d.2 Surfaces 203 e2e3u_crs(:,:,:)=0._wp 204 e2e3u_msk(:,:,:)=0._wp 205 e1e3v_crs(:,:,:)=0._wp 206 e1e3v_msk(:,:,:)=0._wp 192 207 CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=e1t, p_e2=e2t ) 193 208 WRITE(narea+200,*)"e1e2w_crs(2,18,1) ",e1e2w_crs(2,18,1) … … 207 222 208 223 facsurfu(ji,jj,jk) = umask_crs(ji,jj,jk) * e2e3u_msk(ji,jj,jk) 209 IF( e2e3u_crs(ji,jj,jk) .NE. 0._wp ) facsurfu(ji,jj,jk) = facsurfu(ji,jj,jk) / e2e3u_crs(ji,jj,jk) 224 225 IF( facsurfu(ji,jj,jk) .NE. facsurfu(ji,jj,jk) )WRITE(narea+200,*)'BUG1',facsurfu(ji,jj,jk);call flush(narea+200) 226 IF( e2e3u_crs(ji,jj,jk) .NE. e2e3u_crs(ji,jj,jk) ) WRITE(narea+200,*)'BUG2',e2e3u_crs(ji,jj,jk);call flush(narea+200) 227 IF( e2e3u_msk(ji,jj,jk) .NE. e2e3u_msk(ji,jj,jk) ) WRITE(narea+200,*)'BUG3',e2e3u_msk(ji,jj,jk) ;call flush(narea+200) 228 IF( e1e2w_msk(ji,jj,jk) .NE. e1e2w_msk(ji,jj,jk) ) WRITE(narea+200,*)'BUG4',ji,jj,jk,e1e2w_msk(ji,jj,jk) ;call flush(narea+200) 229 IF( tmask(ji,jj,jk) .NE. tmask(ji,jj,jk) ) WRITE(narea+200,*)'BUG4',tmask(ji,jj,jk) ;call flush(narea+200) 230 IF( e1t(ji,jj) .NE. e1t(ji,jj) ) WRITE(narea+200,*)'BUG5',e1t(ji,jj) ;call flush(narea+200) 231 IF( e1t(ji,jj) .NE. e2t(ji,jj) ) WRITE(narea+200,*)'BUG6',e2t(ji,jj) ;call flush(narea+200) 210 232 211 233 facsurfv(ji,jj,jk) = vmask_crs(ji,jj,jk) * e1e3v_msk(ji,jj,jk) … … 224 246 CALL crs_dom_e3( e1v, e2v, zfse3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) 225 247 CALL crs_dom_e3( e1t, e2t, zfse3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs) 248 WHERE(e3t_max_crs == 0._wp) e3t_max_crs=r_inf 249 WHERE(e3u_max_crs == 0._wp) e3u_max_crs=r_inf 250 WHERE(e3v_max_crs == 0._wp) e3v_max_crs=r_inf 251 WHERE(e3w_max_crs == 0._wp) e3w_max_crs=r_inf 226 252 227 253 ! Reset 0 to e3t_0 or e3w_0 … … 264 290 CALL dom_grid_glo ! Return to parent grid domain 265 291 ENDIF 266 292 293 294 rhop_crs(:,:,:)=0._wp ; rhd_crs(:,:,:)=0._wp ; rb2_crs(:,:,:)=0._wp 295 296 267 297 !--------------------------------------------------------- 268 298 ! 7. Finish and clean-up -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r4990 r5105 149 149 ! ! (mi0=1 and mi1=0 if the global index is not in the local domain) 150 150 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor 151 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimpptea, njmpptno !: i-, j-indexes for each processor's northern and eastern neighbour 151 152 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence 152 153 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit , nlcjt !: dimensions of every subdomain 154 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcitea !: dimensions of every subdomain eastern neighbour 153 155 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit , nldjt !: first, last indoor index for each i-domain 154 156 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit , nlejt !: first, last indoor index for each j-domain … … 337 339 ! 338 340 ALLOCATE( rdttra(jpk), r2dtra(jpk), mig(jpi), mjg(jpj), nfiimpp(jpni,jpnj), & 339 & nfipproc(jpni,jpnj), nfilcit(jpni,jpnj), STAT=ierr(1) ) 341 & nfipproc(jpni,jpnj), nfilcit(jpni,jpnj), & 342 & njmpptno(jpnij), nimpptea(jpnij), nlcitea(jpnij), STAT=ierr(1) ) 340 343 ! 341 344 ALLOCATE( nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r5003 r5105 18 18 !! iom_rstput : write a field in a restart file (interfaced to several routines) 19 19 !!-------------------------------------------------------------------- 20 USE dom_oce ! ocean space and time domain 20 USE dom_oce, ONLY : nimpp, njmpp, nlci, nlcj, nldi, nldj, nlei, nlej, & 21 mig, mjg, narea, & 22 gphiv, gphif, & 23 agrif_root, agrif_cfixed, lk_agrif, & 24 rdt,rdttra, gdept_0, ln_crs, gdepw_0, adatrj, fjulday 25 21 26 USE c1d ! 1D vertical configuration 22 27 USE flo_oce ! floats module declarations -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r4990 r5105 409 409 CALL ldf_dyn_init ! Lateral ocean momentum physics 410 410 IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing 411 411 ! 412 IF( ln_crs .AND. lk_ldfslp ) THEN 413 CALL dom_grid_crs 414 CALL ldf_slp_init_crs 415 CALL dom_grid_glo 416 ENDIF 412 417 ! ! Active tracers 413 418 CALL tra_qsr_init ! penetrative solar radiation qsr 414 419 CALL tra_bbc_init ! bottom heat flux 415 420 IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 421 ! 422 IF( ln_crs .AND. lk_trabbl ) THEN 423 CALL dom_grid_crs 424 CALL tra_bbl_init_crs ! advective (and/or diffusive) bottom boundary layer scheme 425 CALL dom_grid_glo 426 ENDIF 427 ! 416 428 CALL tra_dmp_init ! internal damping trends- tracers 417 429 CALL tra_adv_init ! horizontal & vertical advection … … 434 446 #if defined key_top 435 447 ! ! Passive tracers 448 IF( ln_crs_top ) CALL dom_grid_crs 436 449 CALL trc_init 450 IF( ln_crs_top ) CALL dom_grid_glo 437 451 #endif 438 452 ! ! Diagnostics -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step.F90
r4990 r5105 33 33 USE step_oce ! time stepping definition modules 34 34 USE iom 35 USE crs 35 36 36 37 IMPLICIT NONE … … 138 139 CALL zdf_mxl( kstp ) ! mixed layer depth 139 140 141 IF(ln_crs) CALL zdf_mxl_crs(kstp) 140 142 ! write TKE or GLS information in the restart file 141 143 IF( lrst_oce .AND. lk_zdftke ) CALL tke_rst( kstp, 'WRITE' ) … … 224 226 ! Passive Tracer Model 225 227 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 228 IF( ln_crs ) THEN 229 CALL dom_grid_crs 230 CALL eos_crs(tsb_crs , rhd_crs, rhop_crs) 231 CALL bn2_crs(tsb_crs , rb2_crs) 232 IF( ln_zps ) CALL zps_hde_crs( kstp, 2, tsb_crs, gtsu_crs, gtsv_crs, rhd_crs, gru_crs, grv_crs ) 233 CALL zdf_mxl_crs(kstp) 234 IF( lk_ldfslp .AND. .NOT. ln_traldf_grif ) & 235 CALL ldf_slp_crs( kstp, rhd_crs, rb2_crs ) 236 CALL dom_grid_glo 237 ENDIF 238 239 IF( ln_crs_top ) CALL dom_grid_crs 240 226 241 CALL trc_stp( kstp ) ! time-stepping 242 243 IF( ln_crs_top ) CALL dom_grid_glo 227 244 #endif 228 245 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r4990 r5105 95 95 96 96 USE crsfld ! Standard output on coarse grid (crs_fld routine) 97 USE zdfmxl_crs 98 USE eosbn2_crs 99 USE zpshde_crs 100 USE ldfslp_crs 97 101 98 102 USE asminc ! assimilation increments (tra_asm_inc routine)
Note: See TracChangeset
for help on using the changeset viewer.
