- Timestamp:
- 2015-02-24T15:46:25+01:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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 )
Note: See TracChangeset
for help on using the changeset viewer.
