Changeset 6101
- Timestamp:
- 2015-12-17T16:48:41+01:00 (8 years ago)
- Location:
- branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO
- Files:
-
- 4 added
- 24 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90
r5602 r6101 152 152 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: hdivb_crs , hdivn_crs 153 153 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: sshb_crs, sshn_crs , ssha_crs 154 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: rhop_crs,rhd_crs,r b2_crs154 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: rhop_crs,rhd_crs,rn2_crs,rb2_crs 155 155 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: gru_crs, grv_crs 156 156 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: gtsu_crs, gtsv_crs … … 160 160 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: emp_crs, emp_b_crs, sfx_crs 161 161 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: fmmflx_crs 162 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: utau_crs, vtau_crs 162 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: utau_crs, vtau_crs, taum_crs 163 163 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: rnf_crs 164 164 … … 179 179 ! Vertical diffusion 180 180 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_crs !: vert. diffusivity coef. [m2/s] at w-point for temp 181 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: en_crs !: vert. diffusivity coef. [m2/s] at w-point for temp 182 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: avtb_2d_crs !: vert. diffusivity coef. [m2/s] at w-point for temp 181 183 # if defined key_zdfddm 182 184 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avs_crs !: salinity vertical diffusivity coeff. [m2/s] at w-point … … 261 263 & hdivb_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk) , & 262 264 & rke_crs(jpi_crs,jpj_crs,jpk), rhop_crs(jpi_crs,jpj_crs,jpk) , & 263 & rb2_crs(jpi_crs,jpj_crs,jpk) ,rhd_crs(jpi_crs,jpj_crs,jpk) , rab_crs_n(jpi_crs,jpj_crs,jpk,jpts) , & 265 & rb2_crs(jpi_crs,jpj_crs,jpk) ,rn2_crs(jpi_crs,jpj_crs,jpk) , & 266 & rhd_crs(jpi_crs,jpj_crs,jpk) , rab_crs_n(jpi_crs,jpj_crs,jpk,jpts) , & 267 & avtb_2d_crs(jpi_crs,jpj_crs), & 264 268 & gtsu_crs(jpi_crs,jpj_crs,jpts) ,gtsv_crs(jpi_crs,jpj_crs,jpts) , & 265 269 gru_crs(jpi_crs,jpj_crs) ,grv_crs(jpi_crs,jpj_crs) , STAT=ierr(11)) … … 268 272 & emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), & 269 273 & qsr_crs(jpi_crs ,jpj_crs), wndm_crs(jpi_crs,jpj_crs), utau_crs(jpi_crs,jpj_crs) , & 270 & vtau_crs(jpi_crs,jpj_crs), rnf_crs(jpi_crs ,jpj_crs), &274 & vtau_crs(jpi_crs,jpj_crs), taum_crs(jpi_crs,jpj_crs), rnf_crs(jpi_crs ,jpj_crs), & 271 275 & fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs), fmmflx_crs(jpi_crs ,jpj_crs), STAT=ierr(12) ) 272 276 273 277 #if defined key_traldf_c3d 274 ALLOCATE( ahtt_crs(jpi_crs,jpj_crs,jpk) , ahtu_crs(jpi_crs,jpj_crs,jpk) , ahtv_crs(jpi_crs,jpj_crs,jpk) , ahtw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(13) ) 278 ALLOCATE( ahtt_crs(jpi_crs,jpj_crs,jpk) , ahtu_crs(jpi_crs,jpj_crs,jpk) , & 279 & ahtv_crs(jpi_crs,jpj_crs,jpk) , ahtw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(13) ) 275 280 #elif defined key_traldf_c2d 276 ALLOCATE( ahtt_crs(jpi_crs,jpj_crs ) , ahtu_crs(jpi_crs,jpj_crs ) , ahtv_crs(jpi_crs,jpj_crs ) , ahtw_crs(jpi_crs,jpj_crs ) , STAT=ierr(13) ) 281 ALLOCATE( ahtt_crs(jpi_crs,jpj_crs ) , ahtu_crs(jpi_crs,jpj_crs ) , & 282 & ahtv_crs(jpi_crs,jpj_crs ) , ahtw_crs(jpi_crs,jpj_crs ) , STAT=ierr(13) ) 277 283 #elif defined key_traldf_c1d 278 284 ALLOCATE( ahtt_crs( jpk) , ahtu_crs( jpk) , ahtv_crs( jpk) , ahtw_crs( jpk) , STAT=ierr(13) ) 279 285 #endif 280 286 281 ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsb_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), & 287 ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsb_crs(jpi_crs,jpj_crs,jpk,jpts), & 288 en_crs(jpi_crs,jpj_crs,jpk), avt_crs(jpi_crs,jpj_crs,jpk), & 282 289 # if defined key_zdfddm 283 290 & avs_crs(jpi_crs,jpj_crs,jpk), & -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
r5602 r6101 38 38 USE crslbclnk 39 39 USE lib_mpp 40 40 !cbr USE ieee_arithmetic 41 41 42 42 IMPLICIT NONE … … 57 57 # include "domzgr_substitute.h90" 58 58 59 !! $Id$60 59 CONTAINS 61 60 … … 67 66 INTEGER :: iji, ijj 68 67 REAL(wp) :: zmask 68 INTEGER :: ir,jr 69 69 70 70 ! Initialize … … 130 130 !write(narea+5000,*)"mask ",ijie,ijis,ijjs,ijje 131 131 !ENDIF 132 133 ir=303-nimpp_crs+1 ; jr=302-njmpp_crs+1 134 IF( ji==ir .AND. jj==jr )THEN 135 WRITE(narea+2000,*)"mask",ir,jr,ijis+nimpp-1,ijjs+njmpp-1 136 ENDIF 132 137 133 138 !IF( ijje .GT. jpj )WRITE(narea+200,*)"BUG",jj,ijjs,ijje,SHAPE(tmask) ; call flush(narea+200) … … 215 220 INTEGER :: ji, jj, jk ! dummy loop indices 216 221 INTEGER :: ijis, ijjs 222 INTEGER :: ir,jr 217 223 218 224 … … 225 231 p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 226 232 p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 233 ir=303-nimpp_crs+1 ; jr=302-njmpp_crs+1 234 WRITE(narea+2000,*)"coordT1",ir,jr 235 IF( ji==ir .AND. jj==jr )THEN 236 WRITE(narea+2000,*)"coordT",ir,jr,ijis+nimpp-1,ijjs+njmpp-1 237 ENDIF 227 238 ENDDO 228 239 ENDDO … … 530 541 !! 531 542 !! Arguments 532 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) 533 CHARACTER(len= 3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN543 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid 544 CHARACTER(len=*), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN 534 545 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V 535 546 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask … … 547 558 INTEGER :: ii, ij, ijie, ijje, je_2 548 559 REAL(wp) :: zflcrs, zsfcrs 549 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask 560 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask,ztabtmp 550 561 INTEGER :: iji, ijj 562 INTEGER :: ir,jr 563 REAL(wp), DIMENSION(nn_factx,nn_facty):: ztmp 564 REAL(wp), DIMENSION(nn_factx*nn_facty):: ztmp1 565 REAL(wp), DIMENSION(:), ALLOCATABLE :: ztmp2 566 INTEGER , DIMENSION(1) :: zdim1 567 REAL(wp) :: zmin,zmax 551 568 !!---------------------------------------------------------------- 552 569 … … 554 571 555 572 SELECT CASE ( cd_op ) 556 573 557 574 CASE ( 'VOL' ) 558 575 … … 633 650 & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 634 651 & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 635 636 652 zsfcrs = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 637 653 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 638 654 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 639 655 ! 656 !cbr IF( ieee_is_nan(p_fld_crs(ii,ij,jk))) THEN 657 640 658 p_fld_crs(ii,ij,jk) = zflcrs 641 659 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs … … 648 666 649 667 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 650 668 CASE ( 'LOGVOL' ) 669 670 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk, ztabtmp ) 671 672 zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"p_fld",zmin,zmax; CALL flush(numout) 673 674 ztabtmp(:,:,:)=0._wp 675 WHERE(p_fld* p_mask .NE. 0._wp ) ztabtmp = LOG10(p_fld * p_mask)*p_mask 676 zmin=MINVAL(ztabtmp) ; zmax=MAXVAL(ztabtmp);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"LOG()",zmin,zmax; CALL flush(numout) 677 ztabtmp = ztabtmp * p_mask 678 zmin=MINVAL(ztabtmp) ; zmax=MAXVAL(ztabtmp);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"LOG()*tmask",zmin,zmax; CALL flush(numout) 679 680 SELECT CASE ( cd_type ) 681 682 CASE( 'T', 'W' ) 683 DO jk = 1, jpk 684 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 685 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 686 ENDDO 687 688 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 689 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 690 je_2 = mje_crs(2) 691 DO jk = 1, jpk 692 DO ji = nistr, niend, nn_factx 693 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 694 zflcrs = ztabtmp(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & 695 & + ztabtmp(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & 696 & + ztabtmp(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 697 698 zsfcrs = zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 699 ! 700 p_fld_crs(ii,2,jk) = 0._wp 701 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 702 p_fld_crs(ii,2,jk) = 10 ** ( p_fld_crs(ii,2,jk) * p_mask_crs(ii,2,jk) ) * p_mask_crs(ii,2,jk) 703 ENDDO 704 ENDDO 705 ENDIF 706 ELSE 707 je_2 = mjs_crs(2) 708 DO jk = 1, jpk 709 DO ji = nistr, niend, nn_factx 710 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 711 zflcrs = ztabtmp(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & 712 & + ztabtmp(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & 713 & + ztabtmp(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & 714 & + ztabtmp(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & 715 & + ztabtmp(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 716 & + ztabtmp(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 717 & + ztabtmp(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & 718 & + ztabtmp(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 719 & + ztabtmp(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 720 721 zsfcrs = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 722 & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 723 & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 724 ! 725 p_fld_crs(ii,2,jk) = 0._wp 726 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 727 p_fld_crs(ii,2,jk) = 10 ** ( p_fld_crs(ii,2,jk) * p_mask_crs(ii,2,jk) ) * p_mask_crs(ii,2,jk) 728 ENDDO 729 ENDDO 730 ENDIF 731 ! 732 DO jk = 1, jpk 733 DO jj = njstr, njend, nn_facty 734 DO ji = nistr, niend, nn_factx 735 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 736 ij = ( jj - njstr ) * rfacty_r + 3 737 zflcrs = ztabtmp(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & 738 & + ztabtmp(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & 739 & + ztabtmp(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & 740 & + ztabtmp(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & 741 & + ztabtmp(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 742 & + ztabtmp(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 743 & + ztabtmp(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & 744 & + ztabtmp(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 745 & + ztabtmp(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 746 zsfcrs = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 747 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 748 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 749 ! 750 p_fld_crs(ii,ij,jk) = 0._wp 751 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 752 p_fld_crs(ii,ij,jk) = 10 ** ( p_fld_crs(ii,ij,jk) * p_mask_crs(ii,ij,jk) ) * p_mask_crs(ii,ij,jk) 753 ENDDO 754 ENDDO 755 ENDDO 756 CASE DEFAULT 757 STOP 758 END SELECT 759 760 761 !WHERE( p_fld .NE. 0._wp ) p_fld=10**(p_fld) 762 !zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld)",zmin,zmax ; CALL flush(numout) 763 !p_fld = p_fld * p_mask 764 !zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld)*tmask",zmin,zmax ; CALL flush(numout) 765 766 zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"p_fld_crs",zmin,zmax; CALL flush(numout) 767 !p_fld_crs=10**(p_fld_crs*p_mask_crs) 768 !zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld_crs)",zmin,zmax; CALL flush(numout) 769 !p_fld_crs=p_fld_crs*p_mask_crs 770 !zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld_crs)*tmask",zmin,zmax; CALL flush(numout) 771 772 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp ) 773 CASE ( 'MED' ) 774 775 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 776 777 SELECT CASE ( cd_type ) 778 779 CASE( 'T', 'W' ) 780 DO jk = 1, jpk 781 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 782 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 783 ENDDO 784 785 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 786 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 787 je_2 = mje_crs(2) 788 DO jk = 1, jpk 789 DO ji = nistr, niend, nn_factx 790 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 791 792 ztmp1(:) = 0._wp 793 ztmp1(1:3) = p_fld(ji:ji+2,je_2,jk) 794 CALL PIKSRT(nn_factx*nn_facty,ztmp1) 795 ir=0 796 jr=1 797 DO WHILE( jr .LE. nn_factx*nn_facty ) 798 IF( ztmp1(jr) == 0. )THEN 799 ir=jr 800 jr=jr+1 801 ELSE 802 EXIT 803 ENDIF 804 ENDDO 805 IF( ir .LE. nn_factx*nn_facty-1 )THEN 806 ALLOCATE( ztmp2(nn_factx*nn_facty-ir) ) 807 ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty) 808 jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1 809 p_fld_crs(ii,2,jk) = ztmp2(jr) 810 DEALLOCATE( ztmp2 ) 811 ELSE 812 p_fld_crs(ii,ij,jk) = 0._wp 813 ENDIF 814 815 ENDDO 816 ENDDO 817 ENDIF 818 ELSE 819 je_2 = mjs_crs(2) 820 DO jk = 1, jpk 821 DO ji = nistr, niend, nn_factx 822 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 823 824 ztmp(:,:)= p_fld(ji:ji+2,je_2:je_2+2,jk) 825 zdim1(1)=nn_factx*nn_facty 826 ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 ) 827 CALL PIKSRT(nn_factx*nn_facty,ztmp1) 828 ir=0 829 jr=1 830 DO WHILE( jr .LE. nn_factx*nn_facty ) 831 IF( ztmp1(jr) == 0. ) THEN 832 ir=jr 833 jr=jr+1 834 ELSE 835 EXIT 836 ENDIF 837 ENDDO 838 IF( ir .LE. nn_factx*nn_facty-1 )THEN 839 ALLOCATE( ztmp2(nn_factx*nn_facty-ir) ) 840 ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty) 841 jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1 842 p_fld_crs(ii,2,jk) = ztmp2(jr) 843 DEALLOCATE( ztmp2 ) 844 ELSE 845 p_fld_crs(ii,ij,jk) = 0._wp 846 ENDIF 847 848 ENDDO 849 ENDDO 850 ENDIF 851 ! 852 DO jk = 1, jpk 853 DO jj = njstr, njend, nn_facty 854 DO ji = nistr, niend, nn_factx 855 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 856 ij = ( jj - njstr ) * rfacty_r + 3 857 858 ztmp(:,:)= p_fld(ji:ji+2,jj:jj+2,jk) 859 zdim1(1)=nn_factx*nn_facty 860 ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 ) 861 CALL PIKSRT(nn_factx*nn_facty,ztmp1) 862 ir=0 863 jr=1 864 DO WHILE( jr .LE. nn_factx*nn_facty ) 865 IF( ztmp1(jr) == 0. ) THEN 866 ir=jr 867 jr=jr+1 868 ELSE 869 EXIT 870 ENDIF 871 ENDDO 872 IF( ir .LE. nn_factx*nn_facty-1 )THEN 873 ALLOCATE( ztmp2(nn_factx*nn_facty-ir) ) 874 ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty) 875 jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1 876 p_fld_crs(ii,ij,jk) = ztmp2(jr) 877 DEALLOCATE( ztmp2 ) 878 ELSE 879 p_fld_crs(ii,ij,jk) = 0._wp 880 ENDIF 881 882 ENDDO 883 ENDDO 884 ENDDO 885 CASE DEFAULT 886 STOP 887 END SELECT 888 889 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 890 651 891 CASE ( 'SUM' ) 652 892 … … 2390 2630 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 2391 2631 2392 CALL wrk_dealloc( jpi, jpj, jpk, zsurf msk, zsurf)2632 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 2393 2633 2394 2634 END SUBROUTINE crs_dom_sfc … … 2893 3133 ENDDO 2894 3134 3135 CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 3136 2895 3137 zmbk(:,:) = 0.0 2896 3138 zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0) ; mbathy_crs(:,:) = INT( zmbk(:,:) ) … … 2921 3163 END SUBROUTINE crs_dom_bat 2922 3164 3165 SUBROUTINE PIKSRT(N,ARR) 3166 INTEGER ,INTENT(IN) :: N 3167 REAL(kind=8),DIMENSION(N),INTENT(INOUT) :: ARR 3168 3169 INTEGER :: i,j 3170 REAL(kind=8) :: a 3171 !!---------------------------------------------------------------- 3172 3173 DO j=2, N 3174 a=ARR(j) 3175 DO i=j-1,1,-1 3176 IF(ARR(i)<=a) goto 10 3177 ARR(i+1)=ARR(i) 3178 ENDDO 3179 i=0 3180 10 ARR(i+1)=a 3181 ENDDO 3182 RETURN 3183 3184 END SUBROUTINE PIKSRT 3185 2923 3186 2924 3187 END MODULE crsdom -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90
r5602 r6101 27 27 USE iom 28 28 USE zdfmxl_crs 29 USE eosbn2 30 USE zdfevd_crs 31 USE zdftke 32 USE zdftke_crs 33 34 ! USE ieee_arithmetic 29 35 30 36 IMPLICIT NONE … … 40 46 !!---------------------------------------------------------------------- 41 47 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 42 !! $Id $48 !! $Id $ 43 49 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 44 50 !!---------------------------------------------------------------------- … … 65 71 !! 66 72 REAL(wp), POINTER, DIMENSION(:,:,:) :: zfse3t, zfse3u, zfse3v, zfse3w ! 3D workspace for e3 67 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt, zs 73 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt, zs , ztmp 68 74 REAL(wp), POINTER, DIMENSION(:,:) :: z2d,z2d_crs 69 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt_crs, zs_crs ! 75 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt_crs, zs_crs, zerr_crs,zmax_crs 76 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztmp_crs 77 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: avte_crs 70 78 REAL(wp) :: z2dcrsu, z2dcrsv 71 REAL(wp) :: zmin,zmax 79 REAL(wp) :: zmin,zmax,icnt1,icnt2 72 80 INTEGER :: i,j,ijis,ijie,ijjs,ijje 73 81 REAL(wp) :: zw,zwp1,zum1,zu,zvm1,zv,zsnm,zsm,z 82 REAL(wp) :: zerr, zerr0, zerr1, zmean 83 INTEGER,DIMENSION(4,3) :: ind 84 REAL(wp),DIMENSION(4) :: zwgt 74 85 INTEGER :: iji,ijj 86 INTEGER :: jl,jm,jn 75 87 !! 76 88 !!---------------------------------------------------------------------- … … 81 93 CALL wrk_alloc( jpi, jpj, jpk, zfse3t, zfse3w ) 82 94 CALL wrk_alloc( jpi, jpj, jpk, zfse3u, zfse3v ) 83 CALL wrk_alloc( jpi, jpj, jpk, zt, zs )95 CALL wrk_alloc( jpi, jpj, jpk, zt, zs , ztmp ) 84 96 CALL wrk_alloc( jpi, jpj, z2d ) 85 97 ! 86 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zt_crs, zs_crs ) 98 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zt_crs, zs_crs, zerr_crs,zmax_crs ) 99 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, ztmp_crs ) 100 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, 4, avte_crs ) 87 101 CALL wrk_alloc( jpi_crs, jpj_crs, z2d_crs ) 88 102 … … 129 143 CALL iom_put( "sst" , tsn_crs(:,:,1,jp_tem) ) ! sst 130 144 131 145 !n2 before 146 zt(:,:,:) = rn2b(:,:,:) ; zt_crs(:,:,:) = 0._wp 147 CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 148 rb2_crs(:,:,:) = zt_crs(:,:,:) 149 CALL iom_put("rb2_crs",rb2_crs) 150 132 151 ! Salinity 133 152 zs(:,:,:) = tsb(:,:,:,jp_sal) ; zs_crs(:,:,:) = 0._wp … … 252 271 CASE ( 2 ) 253 272 CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=zfse3w, psgn=1.0 ) 273 CASE ( 3 ) 274 CALL crs_dom_ope( avt, 'LOGVOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=zfse3w, p_mask_crs=tmask_crs, psgn=1.0 ) 275 CASE ( 4 ) 276 CALL crs_dom_ope( avt, 'MED', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=zfse3w, psgn=1.0 ) 277 CASE ( 5 ) 278 CALL crs_dom_ope( en , 'VOL', 'W', tmask, en_crs, p_e12=e1e2t, p_e3=zfse3w, psgn=1.0 ) 279 CALL crs_dom_ope( taum , 'SUM', 'T', tmask, taum_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 280 CALL crs_dom_ope( rn2(:,:,:), 'VOL', 'W', tmask, rn2_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 281 IF( kt==nit000 )CALL tke_avn_ini_crs 282 CALL tke_avn_crs 283 CALL zdf_evd_crs(kt) 284 CASE ( 6 ) 285 286 avte_crs(:,:,:,:) = 0._wp 287 ztmp(:,:,:)=1. 288 289 zt(:,:,:) = 0._wp 290 zs(:,:,:) = 0._wp 291 DO jk=2,jpk 292 WHERE( fse3w(:,:,jk) .NE. 0._wp) zs(:,:,jk) = ( tsn(:,:,jk-1,jp_tem) - tsn(:,:,jk,jp_tem) ) / fse3w(:,:,jk) 293 zt(:,:,jk)= avt(:,:,jk) * zs(:,:,jk) 294 ENDDO 295 CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 296 CALL crs_dom_ope( zs, 'VOL', 'W', tmask, zs_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 297 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte1_crs",zmin,zmax 298 zmin=MINVAL(zs_crs);zmax=MAXVAL(zs_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte1_crs",zmin,zmax 299 zt_crs=tmask_crs*zt_crs 300 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte1_crs",zmin,zmax 301 WHERE( zs_crs .NE. 0._wp ) avte_crs(:,:,:,1) = zt_crs / zs_crs 302 zmin=MINVAL(avte_crs(:,:,:,1));zmax=MAXVAL(avte_crs(:,:,:,1));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte1_crs",zmin,zmax 303 304 zt(:,:,:) = 0._wp 305 zs(:,:,:) = 0._wp 306 DO jk=2,jpk 307 WHERE( fse3w(:,:,jk) .NE. 0._wp) zs(:,:,jk) = ( tsn(:,:,jk-1,jp_sal) - tsn(:,:,jk,jp_sal) ) / fse3w(:,:,jk) 308 zt(:,:,jk)= avt(:,:,jk) * zs(:,:,jk) 309 ENDDO 310 CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 311 CALL crs_dom_ope( zs, 'VOL', 'W', tmask, zs_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 312 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte2_crs",zmin,zmax 313 zmin=MINVAL(zs_crs);zmax=MAXVAL(zs_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte2_crs",zmin,zmax 314 zt_crs=tmask_crs*zt_crs 315 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte1_crs",zmin,zmax 316 WHERE( zs_crs .NE. 0._wp ) avte_crs(:,:,:,2) = zt_crs / zs_crs 317 zmin=MINVAL(avte_crs(:,:,:,2));zmax=MAXVAL(avte_crs(:,:,:,2));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte2_crs",zmin,zmax 318 319 zt(:,:,:) = 0._wp 320 zs(:,:,:) = 0._wp 321 DO jk=2,jpk 322 WHERE( fse3w(:,:,jk) .NE. 0._wp ) zs(:,:,jk)= ( rn_a0 * ( tsn(:,:,jk-1,jp_tem) - tsn(:,:,jk,jp_tem) ) + & 323 & rn_b0 * ( tsn(:,:,jk-1,jp_sal) - tsn(:,:,jk,jp_sal) ) )/ fse3w(:,:,jk) 324 zt(:,:,jk)= avt(:,:,jk) * zs(:,:,jk) 325 ENDDO 326 CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 327 CALL crs_dom_ope( zs, 'VOL', 'W', tmask, zs_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 328 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte3_crs",zmin,zmax 329 zmin=MINVAL(zs_crs);zmax=MAXVAL(zs_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte3_crs",zmin,zmax 330 zt_crs=tmask_crs*zt_crs 331 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte3_crs",zmin,zmax 332 WHERE( zs_crs .NE. 0._wp ) avte_crs(:,:,:,3) = zt_crs / zs_crs 333 zmin=MINVAL(avte_crs(:,:,:,3));zmax=MAXVAL(avte_crs(:,:,:,3));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte3_crs",zmin,zmax 334 335 zt(:,:,:) = 0._wp 336 zs(:,:,:) = 0._wp 337 DO jk=2,jpk 338 WHERE( fse3w(:,:,jk) .NE. 0._wp ) zs(:,:,jk)= ( rn_a0 * ( tsn(:,:,jk-1,jp_tem) - tsn(:,:,jk,jp_tem) ) - & 339 & rn_b0 * ( tsn(:,:,jk-1,jp_sal) - tsn(:,:,jk,jp_sal) ) )/ fse3w(:,:,jk) 340 zt(:,:,jk)= avt(:,:,jk) * zs(:,:,jk) 341 ENDDO 342 CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 343 CALL crs_dom_ope( zs, 'VOL', 'W', tmask, zs_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 344 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte4_crs",zmin,zmax 345 zmin=MINVAL(zs_crs);zmax=MAXVAL(zs_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte4_crs",zmin,zmax 346 zt_crs=tmask_crs*zt_crs 347 zmin=MINVAL(zt_crs);zmax=MAXVAL(zt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte4_crs",zmin,zmax 348 WHERE( zs_crs .NE. 0._wp ) avte_crs(:,:,:,4) = zt_crs / zs_crs 349 zmin=MINVAL(avte_crs(:,:,:,4));zmax=MAXVAL(avte_crs(:,:,:,4));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avte4_crs",zmin,zmax 350 351 CALL iom_put( "avte_crs1", avte_crs(:,:,:,1) ) ! Kz 352 CALL iom_put( "avte_crs2", avte_crs(:,:,:,2) ) ! Kz 353 CALL iom_put( "avte_crs3", avte_crs(:,:,:,3) ) ! Kz 354 CALL iom_put( "avte_crs4", avte_crs(:,:,:,4) ) ! Kz 355 !--------------------- 356 CALL crs_dom_ope( avt, 'MED', 'W', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3w, p_mask_crs=tmask_crs, psgn=1.0 ) 357 !? zmin=MINVAL(zs_crs*tmask_crs);zmax=MAXVAL(zs_crs*tmask_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"logvol zs_crs*tmask ",zmin,zmax ; call flush(numout) 358 CALL iom_put( "zs_crs", zs_crs ) ! Kzlogvol 359 !--------------------- ok 360 361 CALL crs_dom_ope( avt, 'VOL', 'W', tmask, zmax_crs, p_e12=e1e2t, p_e3=zfse3w, psgn=1.0 ) 362 WRITE(narea+200,*)"zmax_crs ",SHAPE(zmax_crs) ; call flush(narea+200) 363 CALL iom_put( "zmax_crs", zmax_crs ) ! Kzlogvol 364 zmin=MINVAL(zmax_crs*tmask_crs);zmax=MAXVAL(zmax_crs*tmask_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"vol zmax_crs*tmask ",zmin,zmax ; call flush(numout) 365 !-------------------------nok 366 avt_crs=zs_crs 367 368 369 zerr0=0.01 370 371 icnt1=0 372 icnt2=0 373 374 zt_crs(:,:,:)=0._wp 375 zerr_crs(:,:,:)=0._wp 376 DO ji=1,jpi_crs 377 DO jj=1,jpj_crs 378 DO jk=1,jpk 379 380 381 !-------------- 382 zwgt(1:4)=0._wp 383 DO jm=1,4 ; IF( avte_crs(ji,jj,jk,jm) .GE. 0._wp .AND. avte_crs(ji,jj,jk,jm) .LE. zmax_crs(ji,jj,jk) ) zwgt(jm) = 1._wp ; ENDDO 384 !-------------- 385 IF( SUM(zwgt(1:4)) .NE. 0._wp ) THEN 386 zmean = SUM( zwgt(1:4)*avte_crs(ji,jj,jk,1:4)) / SUM(zwgt(1:4) ) 387 zerr = SQRT(SUM( zwgt(1:4)*(avte_crs(ji,jj,jk,1:4)-zmean)*(avte_crs(ji,jj,jk,1:4)-zmean) ) / SUM(zwgt(1:4) ) ) 388 ELSE 389 zmean=0._wp 390 zerr=1.e10 391 ENDIF 392 !-------------- 393 394 zerr_crs(ji,jj,jk)=zerr 395 396 IF( zerr .LE. zerr0 .AND. zmean .GT. 0._wp )zt_crs(ji,jj,jk)=zmean 397 IF( zerr .LE. zerr0 .AND. zmean .GT. 0._wp )avt_crs(ji,jj,jk)=zmean 398 399 IF( tmask_crs(ji,jj,jk) == 1 ) icnt1=icnt1+1 400 IF( tmask_crs(ji,jj,jk) == 1 .AND. zerr .LE. zerr0 .AND. zmean .GT. 0._wp ) icnt2=icnt2+1 401 402 !IF( ieee_is_nan( zt_crs(ji,jj,jk)) )WRITE(narea+200,*)"NANMEANEFF ",ji,jj,jk,tmask_crs(ji,jj,jk) ; call flush(narea+200) 403 !IF( ieee_is_nan( zs_crs(ji,jj,jk)) )WRITE(narea+200,*)"NANLOG ",ji,jj,jk,tmask_crs(ji,jj,jk) ; call flush(narea+200) 404 !IF( ieee_is_nan( avt_crs(ji,jj,jk)) )WRITE(narea+200,*)"NANAVT ",ji,jj,jk,tmask_crs(ji,jj,jk) ; call flush(narea+200) 405 ENDDO 406 ENDDO 407 ENDDO 408 zmin=MINVAL(avt_crs);zmax=MAXVAL(avt_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avt_crs ",zmin,zmax ; call flush(numout) 409 zmin=MINVAL(avt_crs*tmask_crs);zmax=MAXVAL(avt_crs*tmask_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"avt_crs*tmask ",zmin,zmax ; call flush(numout) 410 411 CALL mpp_sum(icnt1) 412 CALL mpp_sum(icnt2) 413 IF(lwp)WRITE(numout,*)"TOTO",kt,icnt1,icnt2 414 CALL iom_put( "zt_crs", zt_crs ) ! Kz 415 CALL iom_put( "zerr_crs", zerr_crs ) ! Kz 416 254 417 END SELECT 255 418 ! … … 293 456 CALL wrk_dealloc( jpi, jpj, jpk, zfse3t, zfse3w ) 294 457 CALL wrk_dealloc( jpi, jpj, jpk, zfse3u, zfse3v ) 295 CALL wrk_dealloc( jpi, jpj, jpk, zt, zs 458 CALL wrk_dealloc( jpi, jpj, jpk, zt, zs, ztmp ) 296 459 CALL wrk_dealloc( jpi, jpj, z2d ) 297 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zt_crs, zs_crs ) 460 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zt_crs, zs_crs, zerr_crs,zmax_crs ) 461 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, ztmp_crs ) 462 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, 4, avte_crs ) 298 463 CALL wrk_dealloc( jpi_crs, jpj_crs, z2d_crs ) 299 464 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
r5602 r6101 256 256 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=zfse3w, psgn=1.0 ) 257 257 258 259 258 !--------------------------------------------------------- 260 259 ! 4. Coarse grid ocean volume and averaging weights -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r5602 r6101 22 22 gphiv, gphif, & 23 23 agrif_root, agrif_cfixed, lk_agrif, & 24 rdt,rdttra, gdept_0, ln_crs, gdepw_0, adatrj, fjulday 24 rdt,rdttra, gdept_0, ln_crs, gdepw_0, adatrj, fjulday, & 25 mikt 25 26 26 27 USE c1d ! 1D vertical configuration -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp_crs.F90
r5601 r6101 493 493 ! 494 494 ELSE ! Madec operator : slopes at u-, v-, and w-points 495 ALLOCATE( uslp_crs(jpi_crs,jpj_crs,jpk) , vslp_crs(jpi_crs,jpj_crs,jpk) , wslpi_crs(jpi_crs,jpj_crs,jpk) , wslpj_crs(jpi_crs,jpj_crs,jpk) , & 496 & omlmask(jpi_crs,jpj_crs,jpk) , uslpml(jpi_crs,jpj_crs) , vslpml(jpi_crs,jpj_crs) , wslpiml(jpi_crs,jpj_crs) , wslpjml(jpi_crs,jpj_crs) , STAT=ierr ) 495 ALLOCATE( uslp_crs(jpi_crs,jpj_crs,jpk) , vslp_crs(jpi_crs,jpj_crs,jpk) , & 496 & wslpi_crs(jpi_crs,jpj_crs,jpk) , wslpj_crs(jpi_crs,jpj_crs,jpk) , & 497 & omlmask(jpi_crs,jpj_crs,jpk) , & 498 & uslpml(jpi_crs,jpj_crs) , vslpml(jpi_crs,jpj_crs) , & 499 & wslpiml(jpi_crs,jpj_crs) , wslpjml(jpi_crs,jpj_crs) , STAT=ierr ) 497 500 IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) 498 501 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r5602 r6101 80 80 ! !!! simplified eos coefficients 81 81 ! default value: Vallis 2006 82 REAL(wp) :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff.83 REAL(wp) :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff.82 REAL(wp), PUBLIC :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. 83 REAL(wp), PUBLIC :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. 84 84 REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 85 85 REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd_crs.F90
r5601 r6101 178 178 END IF 179 179 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 180 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN181 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) )182 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) )180 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 181 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) 182 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) 183 183 ENDIF 184 184 … … 240 240 END IF 241 241 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) 242 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN243 IF( jn == jp_tem ) htr_adv(:) = ptr_ vj( zwy(:,:,:) ) + htr_adv(:)244 IF( jn == jp_sal ) str_adv(:) = ptr_ vj( zwy(:,:,:) ) + str_adv(:)242 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 243 IF( jn == jp_tem ) htr_adv(:) = ptr_sj( zwy(:,:,:) ) + htr_adv(:) 244 IF( jn == jp_sal ) str_adv(:) = ptr_sj( zwy(:,:,:) ) + str_adv(:) 245 245 ENDIF 246 246 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_crs.F90
r5601 r6101 219 219 ! 220 220 ! "Poleward" diffusive heat or salt transports (T-S case only) 221 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN222 IF( jn == jp_tem) htr_ldf(:) = ptr_ vj( zftv(:,:,:) )223 IF( jn == jp_sal) str_ldf(:) = ptr_ vj( zftv(:,:,:) )221 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 222 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( zftv(:,:,:) ) 223 IF( jn == jp_sal) str_ldf(:) = ptr_sj( zftv(:,:,:) ) 224 224 ENDIF 225 225 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap_crs.F90
r5105 r6101 150 150 ! 151 151 ! "Poleward" diffusive heat or salt transports 152 IF( cdtype == 'TRA' .AND. ln_diaptr .AND. ( MOD( kt, nn_fptr ) == 0 )) THEN153 IF( jn == jp_tem) htr_ldf(:) = ptr_ vj( ztv(:,:,:) )154 IF( jn == jp_sal) str_ldf(:) = ptr_ vj( ztv(:,:,:) )152 IF( cdtype == 'TRA' .AND. ln_diaptr ) THEN 153 IF( jn == jp_tem) htr_ldf(:) = ptr_sj( ztv(:,:,:) ) 154 IF( jn == jp_sal) str_ldf(:) = ptr_sj( ztv(:,:,:) ) 155 155 ENDIF 156 156 ! ! ================== -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90
r5601 r6101 134 134 END DO 135 135 END DO 136 CALL iom_put("hmlpt",hmlpt) 137 136 138 IF( .NOT.lk_offline ) THEN ! no need to output in offline mode 137 139 CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl_crs.F90
r5601 r6101 64 64 REAL(wp) :: zN2_c ! local scalar 65 65 INTEGER, POINTER, DIMENSION(:,:) :: imld ! 2D workspace 66 REAL(wp), POINTER, DIMENSION(:,:) :: z2d ! 2D workspace 66 67 !!---------------------------------------------------------------------- 67 68 ! … … 69 70 ! 70 71 CALL wrk_alloc( jpi_crs,jpj_crs, imld ) 72 CALL wrk_alloc( jpi_crs,jpj_crs, z2d ) 71 73 72 74 IF( kt == nit000 ) THEN … … 98 100 END DO 99 101 ! 102 z2d=REAL(nmln_crs,wp) 103 CALL iom_put("nmln_crs",z2d) 104 CALL iom_put("hmlpt_crs",hmlpt_crs) 105 ! 100 106 CALL wrk_dealloc( jpi_crs,jpj_crs, imld ) 107 CALL wrk_dealloc( jpi_crs,jpj_crs, z2d ) 101 108 ! 102 109 IF( nn_timing == 1 ) CALL timing_stop('zdf_mxl_crs') -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r5602 r6101 64 64 65 65 ! !!** Namelist namzdf_tke ** 66 LOGICAL :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not67 INTEGER :: nn_mxl ! type of mixing length (=0/1/2/3)68 REAL(wp) :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m]69 INTEGER :: nn_pdl ! Prandtl number or not (ratio avt/avm) (=0/1)70 REAL(wp) :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e)66 LOGICAL , PUBLIC :: ln_mxl0 ! mixing length scale surface value as function of wind stress or not 67 INTEGER , PUBLIC :: nn_mxl ! type of mixing length (=0/1/2/3) 68 REAL(wp) , PUBLIC :: rn_mxl0 ! surface min value of mixing length (kappa*z_o=0.4*0.1 m) [m] 69 INTEGER , PUBLIC :: nn_pdl ! Prandtl number or not (ratio avt/avm) (=0/1) 70 REAL(wp) , PUBLIC :: rn_ediff ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) 71 71 REAL(wp) :: rn_ediss ! coefficient of the Kolmogoroff dissipation 72 72 REAL(wp) :: rn_ebb ! coefficient of the surface input of tke 73 73 REAL(wp) :: rn_emin ! minimum value of tke [m2/s2] 74 74 REAL(wp) :: rn_emin0 ! surface minimum value of tke [m2/s2] 75 REAL(wp) :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it)75 REAL(wp) , PUBLIC :: rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) 76 76 INTEGER :: nn_etau ! type of depth penetration of surface tke (=0/1/2/3) 77 77 INTEGER :: nn_htau ! type of tke profile of penetration (=0/1) … … 81 81 82 82 REAL(wp) :: ri_cri ! critic Richardson number (deduced from rn_ediff and rn_ediss values) 83 REAL(wp) :: rmxl_min ! minimum mixing length value (deduced from rn_ediff and rn_emin values) [m]83 REAL(wp) , PUBLIC :: rmxl_min ! minimum mixing length value (deduced from rn_ediff and rn_emin values) [m] 84 84 REAL(wp) :: rhftau_add = 1.e-3_wp ! add offset applied to HF part of taum (nn_etau=3) 85 85 REAL(wp) :: rhftau_scl = 1.0_wp ! scale factor applied to HF part of taum (nn_etau=3) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step.F90
r5602 r6101 33 33 USE step_oce ! time stepping definition modules 34 34 USE iom 35 USE crs35 use wrk_nemo 36 36 37 37 IMPLICIT NONE … … 76 76 INTEGER :: indic ! error indicator if < 0 77 77 INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt) 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zrhop,zrhd 79 78 80 !! --------------------------------------------------------------------- 79 81 … … 117 119 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 118 120 ! THERMODYNAMICS 119 !cbr not usedCALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points120 !cbr not usedCALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points121 CALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points 122 CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points 121 123 CALL bn2 ( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency 122 124 CALL bn2 ( tsn, rab_n, rn2 ) ! now Brunt-Vaisala frequency … … 169 171 CALL iom_put("rhd",rhd) 170 172 CALL iom_put("rn2b",rn2b) 173 CALL iom_put("rn2",rn2) 171 174 CALL ldf_slp( kstp, rhd, rn2b ) ! before slope for Madec operator 172 175 ENDIF … … 240 243 IF( ln_crs ) CALL crs_fld( kstp ) ! ocean model: online field coarsening & output 241 244 245 CALL wrk_alloc( jpi, jpj, jpk, zrhop, zrhd ) 246 CALL eos( tsn, zrhd, zrhop, fsdept_n(:,:,:) ) ! now in situ and potential density 247 zrhop(:,:,jpk) = 0._wp 248 CALL iom_put( 'rhop', zrhop ) 249 250 CALL wrk_dealloc( jpi, jpj, jpk, zrhop, zrhd ) 251 242 252 #if defined key_top 243 253 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 247 257 CALL dom_grid_crs 248 258 249 CALL eos_rab_crs( tsn_crs, rab_crs_n ) ! now local thermal/haline expension ratio at T-points250 CALL bn2_crs ( tsn_crs, rab_crs_n, rb2_crs ) ! now Brunt-Vaisala frequency259 !CALL eos_rab_crs( tsn_crs, rab_crs_n ) ! now local thermal/haline expension ratio at T-points 260 !CALL bn2_crs ( tsn_crs, rab_crs_n, rb2_crs ) ! now Brunt-Vaisala frequency 251 261 CALL eos_crs ( tsn_crs, rhd_crs, rhop_crs, gdept_crs(:,:,:) ) ! now in situ density for hpg computation 262 CALL iom_put("rhop_crs",rhop_crs) 263 CALL iom_put("rhd_crs",rhd_crs) 252 264 253 265 IF( ln_zps ) CALL zps_hde_crs( kstp, jpts, tsb_crs, gtsu_crs, gtsv_crs, rhd_crs, gru_crs, grv_crs ) … … 265 277 266 278 IF( ln_crs_top ) CALL dom_grid_glo 279 267 280 #endif 268 281 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/stpctl.F90
r3294 r6101 136 136 WRITE(numout,*) ' output of last fields in numwso' 137 137 ENDIF 138 kindic = -3138 WHERE( tsn(:,:,:,jp_sal) .LE. 0. ) tsn(:,:,:,jp_sal) = 0.1 139 139 ENDIF 140 140 9500 FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90
r5602 r6101 24 24 USE trdtra 25 25 USE trd_oce 26 USE iom 26 USE iom , ONLY : iom_open, iom_get, iom_close, jpdom_autoglo 27 27 28 28 IMPLICIT NONE -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf_crs.F90
r5601 r6101 219 219 IF(lwp) WRITE(numout,*) ' esopa control: use all lateral physics options' 220 220 nldf = -1 221 ENDIF222 223 IF( .NOT. ln_trcldf_diff ) THEN224 IF(lwp) WRITE(numout,*) ' No lateral diffusion on passive tracers'225 nldf = -2226 221 ENDIF 227 222 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
r5602 r6101 19 19 USE trc ! ocean passive tracers variables 20 20 USE prtctl_trc ! Print control for debbuging 21 USE iom 21 USE iom, ONLY : iom_varid, iom_get, iom_rstput,jpdom_autoglo 22 22 USE trd_oce 23 23 USE trdtra -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90
r5602 r6101 34 34 USE zpshde ! partial step: hor. derivative (zps_hde routine) 35 35 USE zpshde_crs ! partial step: hor. derivative (zps_hde routine) 36 USE dom_oce , ONLY : ln_crs 36 USE dom_oce , ONLY : ln_crs, ln_isfcav 37 37 USE crs , ONLY : jpi_crs,jpj_crs,wn_crs,ln_crs_top !cbr 38 38 USE ldfslp_crs 39 40 39 #if defined key_agrif 41 40 USE agrif_top_sponge ! tracers sponges … … 111 110 CALL zps_hde_crs( kstp, jptra, trn, gtru, gtrv ) 112 111 ELSE 113 IF( ln_isfcav ) &112 IF( ln_isfcav )THEN 114 113 CALL zps_hde_isf( kstp, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! Partial steps: now horizontal gradient of passive 115 114 ELSE 116 115 CALL zps_hde ( kstp, jptra, trn, gtru, gtrv ) ! Partial steps: now horizontal gradient of passive 117 116 ENDIF 117 ENDIF 118 118 ENDIF 119 119 ! tracers at the bottom ocean level -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r5602 r6101 76 76 USE dom_oce , ONLY : ln_sco => ln_sco 77 77 USE dom_oce , ONLY : neuler => neuler 78 USE dom_oce , ONLY : mikt => mikt !: f-points (m) 78 79 79 80 USE crs, ONLY : mi0 => mi0 … … 282 283 USE dom_oce , ONLY : mbku => mbku !: f-points (m) 283 284 USE dom_oce , ONLY : mbkv => mbkv !: f-points (m) 285 USE dom_oce , ONLY : mikt => mikt !: f-points (m) 284 286 285 287 !* IO manager * … … 401 403 #endif 402 404 405 406 USE dom_oce , ONLY : ndastp 407 USE sbc_oce , ONLY : nn_ice_embd 408 USE sbc_oce , ONLY : ln_cpl 409 USE sbc_oce , ONLY : ncpl_qsr_freq 410 403 411 #else 404 412 !!---------------------------------------------------------------------- -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcdta.F90
r5602 r6101 19 19 USE oce_trc ! shared variables between ocean and passive tracers 20 20 USE trc ! passive tracers common variables 21 ! USE iom ! I/O manager 21 22 USE lib_mpp ! MPP library 22 23 USE fldread ! read input fields -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r5602 r6101 25 25 USE trcini_my_trc ! MY_TRC initialisation 26 26 USE trcdta ! initialisation from files 27 USE zpshde,ONLY: zps_hde ! partial step: hor. derivative (zps_hde routine)27 USE zpshde,ONLY: zps_hde, zps_hde_isf ! partial step: hor. derivative (zps_hde routine) 28 28 USE zpshde_crs ! partial step: hor. derivative (zps_hde routine) 29 29 USE prtctl_trc ! Print control passive tracers (prt_ctl_trc_init routine) 30 30 USE trcsub ! variables to substep passive tracers 31 31 USE lib_mpp ! distribued memory computing library 32 USE sbc_oce, ONLY : ltrcdm2dc33 32 USE crs , ONLY : ln_crs 34 USE dom_oce, ONLY : nn_cla 33 USE dom_oce, ONLY : nn_cla, ln_isfcav 35 34 USE trcice ! tracers in sea ice 35 USE sbc_oce 36 36 37 37 IMPLICIT NONE … … 148 148 149 149 tra(:,:,:,:) = 0._wp 150 IF( ln_zps .AND. .NOT. lk_c1d )THEN ! Partial steps: before horizontal gradient of passive 151 IF( ln_crs ) THEN 152 CALL zps_hde_crs( nit000, jptra, trn, gtru, gtrv ) 153 ELSE 154 IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav ) & ! Partial steps: before horizontal gradient of passive 155 & CALL zps_hde ( nit000, jptra, trn, gtru, gtrv ) ! Partial steps: before horizontal gradient 156 IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav ) & 157 & CALL zps_hde_isf( nit000, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! tracers at the bottom ocean level 158 ENDIF 150 IF( ln_crs ) THEN 151 CALL zps_hde_crs( nit000, jptra, trn, gtru, gtrv ) 152 ELSE 153 IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav ) & ! Partial steps: before horizontal gradient of passive 154 & CALL zps_hde ( nit000, jptra, trn, gtru, gtrv ) ! Partial steps: before horizontal gradient 155 IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav ) & 156 & CALL zps_hde_isf( nit000, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! tracers at the bottom ocean level 159 157 ENDIF 160 158 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
r5602 r6101 11 11 !!---------------------------------------------------------------------- 12 12 USE oce_trc ! ocean dynamics and active tracers variables 13 USE sbc_oce , ONLY : ltrcdm2dc,qsr_mean14 13 USE trc 15 14 USE trctrp ! passive tracers transport … … 24 23 USE in_out_manager 25 24 USE trcsub 26 USE dom_oce, ONLY : nday, nmonth, nyear 25 USE dom_oce, ONLY : nday, nmonth, nyear, nsec1jan000, nsec_year 26 !USE sbc_oce 27 27 28 28 IMPLICIT NONE -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcwri.F90
r3750 r6101 15 15 USE oce_trc ! shared variables between ocean and passive tracers 16 16 USE trc ! passive tracers common variables 17 USE iom ! I/O manager17 ! USE iom ! I/O manager 18 18 USE dianam ! Output file name 19 19 USE trcwri_pisces
Note: See TracChangeset
for help on using the changeset viewer.