Changeset 6772


Ignore:
Timestamp:
2016-07-01T18:02:45+02:00 (4 years ago)
Author:
cbricaud
Message:

clean in coarsening branch

Location:
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO
Files:
1 added
1 deleted
37 edited

Legend:

Unmodified
Added
Removed
  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r5602 r6772  
    2828   USE lib_fortran      ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    2929   USE wrk_nemo         ! work arrays 
     30   USE fldread          ! read input fields 
     31   USE iom 
    3032 
    3133   IMPLICIT NONE 
     
    4749   REAL(wp) ::   rn_tmi_ini_s   ! initial temperature 
    4850 
     51   INTEGER , PARAMETER ::   jpfldi    = 7           ! maximum number of files to read 
     52   INTEGER , PARAMETER ::   jp_hicif = 1           ! index of thick (m)    at T-point 
     53   INTEGER , PARAMETER ::   jp_hsnif = 2           ! index of thick (m)    at T-point 
     54   INTEGER , PARAMETER ::   jp_frld  = 3           ! index of ice fraction (%) at T-point 
     55   INTEGER , PARAMETER ::   jp_sist  = 4           ! index of ice surface temp (K)    at T-point 
     56   INTEGER , PARAMETER ::   jp_tbif1 = 5           ! index of ice temp lev1 (K) at T-point 
     57   INTEGER , PARAMETER ::   jp_tbif2 = 6           ! index of ice temp lev2 (K) at T-point 
     58   INTEGER , PARAMETER ::   jp_tbif3 = 7           ! index of ice temp lev3 (K) at T-point 
     59   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   si    ! structure of input fields (file informations, fields read) 
     60 
     61   REAL(wp),DIMENSION(:,:)  ,ALLOCATABLE :: hicif_ini,hsnif_ini,frld_ini,sist_ini, zswitch 
     62   REAL(wp),DIMENSION(:,:,:),ALLOCATABLE :: tbif_ini 
     63 
    4964   LOGICAL  ::  ln_iceini    ! initialization or not 
     65   LOGICAL  ::  ln_limini_file   ! Ice initialization state from 2D netcdf file 
    5066   !!---------------------------------------------------------------------- 
    5167   !!   LIM 3.0,  UCL-LOCEAN-IPSL (2008) 
     
    91107      REAL(wp), POINTER, DIMENSION(:)     :: zht_i_ini, zat_i_ini, zvt_i_ini, zht_s_ini, zsm_i_ini, ztm_i_ini 
    92108      REAL(wp), POINTER, DIMENSION(:,:)   :: zh_i_ini, za_i_ini, zv_i_ini 
    93       REAL(wp), POINTER, DIMENSION(:,:)   :: zswitch    ! ice indicator 
    94109      INTEGER,  POINTER, DIMENSION(:,:)   :: zhemis   ! hemispheric index 
    95110      !-------------------------------------------------------------------- 
    96111 
    97       CALL wrk_alloc( jpi, jpj, zswitch ) 
    98112      CALL wrk_alloc( jpi, jpj, zhemis ) 
    99113      CALL wrk_alloc( jpl,   2, zh_i_ini,  za_i_ini,  zv_i_ini ) 
     
    150164      ! 3) Initialization of sea ice state variables 
    151165      !-------------------------------------------------------------------- 
     166      IF( ln_limini_file )THEN 
     167 
     168         CALL limini_file 
     169 
     170      ELSE 
    152171 
    153172      !----------------------------- 
     
    376395      tn_ice (:,:,:) = t_su (:,:,:) 
    377396 
     397      ENDIF !ln_limini_file 
     398 
    378399      ELSE  
    379400         ! if ln_iceini=false 
     
    399420            END DO 
    400421         END DO 
    401        
     422 
    402423      ENDIF ! ln_iceini 
    403424       
     
    451472 
    452473 
    453       CALL wrk_dealloc( jpi, jpj, zswitch ) 
    454474      CALL wrk_dealloc( jpi, jpj, zhemis ) 
    455475      CALL wrk_dealloc( jpl,   2, zh_i_ini,  za_i_ini,  zv_i_ini ) 
     
    474494      !!  8.5  ! 07-11 (M. Vancoppenolle) rewritten initialization 
    475495      !!----------------------------------------------------------------------------- 
    476       NAMELIST/namiceini/ ln_iceini, rn_thres_sst, rn_hts_ini_n, rn_hts_ini_s, rn_hti_ini_n, rn_hti_ini_s,  & 
    477          &                                      rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, rn_smi_ini_s, rn_tmi_ini_n, rn_tmi_ini_s 
    478       INTEGER :: ios                 ! Local integer output status for namelist read 
     496      ! 
     497      INTEGER :: ios,ierr,inum_ice                 ! Local integer output status for namelist read 
     498      INTEGER :: ji,jj 
     499      INTEGER :: ifpr, ierror 
     500      ! 
     501      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ice files 
     502      TYPE(FLD_N)                    ::   sn_hicif, sn_hsnif, sn_frld, sn_sist 
     503      TYPE(FLD_N)                    ::   sn_tbif1, sn_tbif2, sn_tbif3 
     504      TYPE(FLD_N), DIMENSION(jpfldi) ::   slf_i                 ! array of namelist informations on the fields to read 
     505      ! 
     506      NAMELIST/namiceini/ ln_iceini, ln_limini_file, rn_thres_sst, rn_hts_ini_n, rn_hts_ini_s,  & 
     507         &                rn_hti_ini_n, rn_hti_ini_s, rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, & 
     508         &                rn_smi_ini_s, rn_tmi_ini_n, rn_tmi_ini_s,                             & 
     509         &                sn_hicif, sn_hsnif, sn_frld, sn_sist,                                 & 
     510         &                sn_tbif1, sn_tbif2, sn_tbif3, cn_dir 
    479511      !!----------------------------------------------------------------------------- 
    480512      ! 
     
    488520      IF(lwm) WRITE ( numoni, namiceini ) 
    489521 
     522      slf_i(jp_hicif) = sn_hicif  ;  slf_i(jp_hsnif) = sn_hsnif 
     523      slf_i(jp_frld)  = sn_frld   ;  slf_i(jp_sist)  = sn_sist 
     524      slf_i(jp_tbif1) = sn_tbif1  ;  slf_i(jp_tbif2) = sn_tbif2  ; slf_i(jp_tbif3) = sn_tbif3 
     525 
    490526      ! Define the initial parameters 
    491527      ! ------------------------- 
     
    496532         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    497533         WRITE(numout,*) '   initialization with ice (T) or not (F)       ln_iceini     = ', ln_iceini 
     534         WRITE(numout,*) '   initialization with ice (T) or not (F)   ln_limini_file  = ', ln_limini_file 
    498535         WRITE(numout,*) '   threshold water temp. for initial sea-ice    rn_thres_sst  = ', rn_thres_sst 
    499536         WRITE(numout,*) '   initial snow thickness in the north          rn_hts_ini_n  = ', rn_hts_ini_n 
     
    509546      ENDIF 
    510547 
     548      IF( ln_limini_file ) THEN                      ! Ice initialization using input file 
     549         ! 
     550         ierr = alloc_lim_istate_init() 
     551         ! 
     552!         CALL iom_open( 'Ice_initialization.nc', inum_ice ) 
     553!         ! 
     554!         IF( inum_ice > 0 ) THEN 
     555!            IF(lwp) WRITE(numout,*) 
     556!            IF(lwp) WRITE(numout,*) '                  ice state initialization with : Ice_initialization.nc' 
     557! 
     558!            CALL iom_get( inum_ice, jpdom_data, 'hicif', hicif_ini ) 
     559!            CALL iom_get( inum_ice, jpdom_data, 'hsnif', hsnif_ini ) 
     560!            CALL iom_get( inum_ice, jpdom_data, 'frld' , frld_ini  ) 
     561!            CALL iom_get( inum_ice, jpdom_data, 'ts'   , sist_ini  ) 
     562!            CALL iom_get( inum_ice, jpdom_unknown, 'tbif', tbif_ini(1:nlci,1:nlcj,:),   & 
     563!                 &        kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,3 /) ) 
     564!            ! put some values in the extra-halo... 
     565 
     566         ! set si structure 
     567         ALLOCATE( si(jpfldi), STAT=ierror ) 
     568         IF( ierror > 0 ) THEN 
     569            CALL ctl_stop( 'Ice_ini in limistate: unable to allocate si structure' )   ;   RETURN 
     570         ENDIF 
     571 
     572         DO ifpr= 1, jpfldi 
     573            ALLOCATE( si(ifpr)%fnow(jpi,jpj,1) ) 
     574            ALLOCATE( si(ifpr)%fdta(jpi,jpj,1,2) ) 
     575         END DO 
     576 
     577         ! fill si with slf_i and control print 
     578         CALL fld_fill( si, slf_i, cn_dir, 'lim_istate', 'lim istate ini', 'numnam_ice' ) 
     579 
     580         CALL fld_read( nit000, 1, si )                ! input fields provided at the current time-step 
     581 
     582         hicif_ini(:,:)  = si(jp_hicif)%fnow(:,:,1) 
     583         hsnif_ini(:,:)  = si(jp_hsnif)%fnow(:,:,1) 
     584         frld_ini(:,:)   = si(jp_frld)%fnow(:,:,1) 
     585         sist_ini(:,:)   = si(jp_sist)%fnow(:,:,1) 
     586         tbif_ini(:,:,1) = si(jp_tbif1)%fnow(:,:,1) 
     587         tbif_ini(:,:,2) = si(jp_tbif2)%fnow(:,:,1) 
     588         tbif_ini(:,:,3) = si(jp_tbif3)%fnow(:,:,1) 
     589 
     590         DO jj = nlcj+1, jpj   ;   tbif_ini(1:nlci,jj,:) = tbif_ini(1:nlci,nlej,:)   ;   END DO 
     591         DO ji = nlci+1, jpi   ;   tbif_ini(ji    ,: ,:) = tbif_ini(nlei  ,:   ,:)   ;   END DO 
     592 
     593!            CALL iom_close( inum_ice) 
     594!            ! 
     595!         ENDIF 
     596      ENDIF 
     597 
    511598   END SUBROUTINE lim_istate_init 
    512599 
     600   SUBROUTINE limini_file 
     601      !!----------------------------------------------------------------------------- 
     602      !! 
     603      !! 
     604      !! 
     605      !! 
     606      !!----------------------------------------------------------------------------- 
     607      INTEGER    :: jl,ji,jj,jk 
     608      INTEGER    :: jl0 
     609      INTEGER    :: i_fill,jit,jjt 
     610      REAL(wp)   :: ztest_1, ztest_2, ztest_3, ztest_4, ztests, zsigma, zarg, zA, zV, zA_cons, zV_cons, zconv,zH 
     611      REAL(wp)   :: eps=1.e-6 
     612      REAL(wp)   :: zmin,zmax 
     613      !rbb REAL(wp)   :: epsi20,ztmelts,zdh 
     614      REAL(wp)   ::ztmelts,zdh 
     615 
     616      REAL(wp), POINTER, DIMENSION(:,:)   :: zhm_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini, zsm_i_ini 
     617      REAL(wp), POINTER, DIMENSION(:,:,:) :: zv_i_ini 
     618      REAL(wp), POINTER, DIMENSION(:,:,:) :: zht_i_ini,za_i_ini 
     619      REAL(wp), POINTER, DIMENSION(:,:)   :: zidto    ! ice indicator 
     620       !----------------------------------------------------------------------------- 
     621      IF(lwp)WRITE(numout,*)"limistate: read file : " 
     622 
     623      CALL wrk_alloc(jpl,jpi,jpj, zv_i_ini) 
     624      CALL wrk_alloc(    jpi,jpj, zhm_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini, zsm_i_ini ) 
     625      CALL wrk_alloc(    jpl,jpi,jpj,zht_i_ini,za_i_ini) 
     626      CALL wrk_alloc(    jpi,jpj,zidto ) 
     627 
     628      zhm_i_ini(:,:) = hicif_ini(:,:)  ! ice thickness 
     629      zat_i_ini(:,:) = 1._wp - frld_ini(:,:)   ! ice concentration 
     630      zvt_i_ini(:,:) = zhm_i_ini(:,:) * zat_i_ini(:,:)   ! ice volume 
     631      zhm_s_ini(:,:) = hsnif_ini(:,:)  ! snow depth 
     632 
     633      zht_i_ini(:,:,:) = 0._wp 
     634      za_i_ini(:,:,:) = 0._wp 
     635      zv_i_ini(:,:,:) = 0._wp 
     636 
     637      zat_i_ini(:,:) = MIN( zat_i_ini(:,:) , 1.0_wp ) 
     638 
     639 
     640      DO ji = 1, jpi 
     641      DO jj = 1, jpj 
     642 
     643         IF( zat_i_ini(ji,jj) .GT. 0._wp .AND. zhm_i_ini(ji,jj) .GT. 0._wp )THEN 
     644 
     645 
     646            IF( gphit(ji,jj) .GE. 0._wp )THEN ; zsm_i_ini(ji,jj) = rn_smi_ini_n 
     647            ELSE                              ; zsm_i_ini(ji,jj) = rn_smi_ini_s 
     648            ENDIF 
     649 
     650            jl0 = 1 
     651            DO jl = 2, jpl 
     652               IF ( ( zhm_i_ini(ji,jj) .GT. hi_max(jl-1) ) .AND. & 
     653                  (   zhm_i_ini(ji,jj) .LE. hi_max(jl)   )       ) THEN 
     654               jl0 = jl 
     655               ENDIF 
     656            END DO 
     657 
     658            IF( jl0==1 )THEN 
     659 
     660               zht_i_ini(1,ji,jj)       = zhm_i_ini(ji,jj) 
     661               za_i_ini(1,ji,jj)        = zat_i_ini(ji,jj) 
     662               zht_i_ini(2:jpl,ji,jj)   = 0._wp 
     663               za_i_ini(2:jpl,ji,jj)    = 0._wp 
     664 
     665            ELSE ! jl0 ne 1 
     666               ztest_1 = 0 ; ztest_2 = 0 ; ztest_3 = 0 ; ztest_4 = 0 
     667 
     668               DO i_fill = jpl, 1, -1 
     669                  IF( ( ztest_1 + ztest_2 + ztest_3 + ztest_4 ) .NE. 4 ) THEN 
     670 
     671                     !---------------------------- 
     672                     ! fill the i_fill categories 
     673                     !---------------------------- 
     674                     ! *** 1 category to fill 
     675                     IF( i_fill .EQ. 1 ) THEN 
     676                        zht_i_ini(1,ji,jj)       = zhm_i_ini(ji,jj) 
     677                        za_i_ini(1,ji,jj)        = zat_i_ini(ji,jj) 
     678                        zht_i_ini(2:jpl,ji,jj)   = 0._wp 
     679                        za_i_ini(2:jpl,ji,jj)    = 0._wp 
     680                     ELSE 
     681 
     682                        ! *** >1 categores to fill 
     683                        !--- Ice thicknesses in the i_fill - 1 first categories 
     684                        DO jl = 1, i_fill - 1 
     685                           zht_i_ini(jl,ji,jj)    = 0.5 * ( hi_max(jl) + hi_max(jl-1) ) 
     686                        END DO 
     687 
     688                        !--- jl0: most likely index where cc will be maximum 
     689                        DO jl = 1, jpl 
     690                        IF ( ( zhm_i_ini(ji,jj) .GT. hi_max(jl-1) ) .AND. & 
     691                              ( zhm_i_ini(ji,jj) .LE. hi_max(jl)   ) ) THEN 
     692                            jl0 = jl 
     693                        ENDIF 
     694                        END DO 
     695                        jl0 = MIN(jl0, i_fill) 
     696 
     697                        !--- Concentrations 
     698                        za_i_ini(jl0,ji,jj)      = zat_i_ini(ji,jj) / SQRT(REAL(jpl)) 
     699                        DO jl = 1, i_fill - 1 
     700                        IF ( jl .NE. jl0 ) THEN 
     701                             zsigma               = 0.5 * zhm_i_ini(ji,jj) 
     702                             zarg                 = ( zht_i_ini(jl,ji,jj) - zhm_i_ini(ji,jj) ) / zsigma 
     703                             za_i_ini(jl,ji,jj) = za_i_ini(jl0,ji,jj) * EXP(-zarg**2) 
     704                        ENDIF 
     705                        END DO 
     706 
     707                        zA = 0. ! sum of the areas in the jpl categories 
     708                        DO jl = 1, i_fill - 1 
     709                           zA = zA + za_i_ini(jl,ji,jj) 
     710                        END DO 
     711                        za_i_ini(i_fill,ji,jj)   = zat_i_ini(ji,jj) - zA ! ice conc in the last category 
     712                        IF ( i_fill .LT. jpl ) za_i_ini(i_fill+1:jpl, ji,jj) = 0._wp 
     713 
     714                        !--- Ice thickness in the last category 
     715                        zV = 0. ! sum of the volumes of the N-1 categories 
     716                        DO jl = 1, i_fill - 1 
     717                           zV = zV + za_i_ini(jl,ji,jj)*zht_i_ini(jl,ji,jj) 
     718                        END DO 
     719                        zht_i_ini(i_fill,ji,jj) = ( zvt_i_ini(ji,jj) - zV ) /za_i_ini(i_fill,ji,jj) 
     720                        IF ( i_fill .LT. jpl ) zht_i_ini(i_fill+1:jpl, ji,jj) = 0._wp 
     721 
     722                        !--- volumes 
     723                        zv_i_ini(:,ji,jj) = za_i_ini(:,ji,jj) * zht_i_ini(:,ji,jj) 
     724                        IF ( i_fill .LT. jpl ) zv_i_ini(i_fill+1:jpl, ji,jj) = 0._wp 
     725 
     726                     ENDIF ! i_fill 
     727 
     728                     !--------------------- 
     729                     ! Compatibility tests 
     730                     !--------------------- 
     731                     ! Test 1: area conservation 
     732                     zA_cons = SUM(za_i_ini(:,ji,jj)) ; zconv = ABS(zat_i_ini(ji,jj) - zA_cons ) 
     733                     IF ( zconv .LT. 1.0e-6 ) THEN 
     734                        ztest_1 = 1 
     735                     ELSE 
     736                      ! this write is useful 
     737                      !WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(ji,jj) 
     738                      !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
     739                      !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
     740                      !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
     741                      !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
     742                      !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
     743                      !WRITE(numout,*) ' hi_max ',hi_max 
     744                      !WRITE(numout,*) ' jl0 = ',jl0 
     745                      !WRITE(numout,*) ' vol = ',zvt_i_ini(ji,jj),SUM(zv_i_ini(:,ji,jj)) 
     746                      ztest_1 = 0 
     747                     ENDIF 
     748 
     749                     ! Test 2: volume conservation 
     750                     zV_cons = SUM(zv_i_ini(:,ji,jj)) 
     751                     zconv = ABS(zvt_i_ini(ji,jj) - zV_cons) 
     752 
     753                     IF ( zconv .LT. 1.0e-6 ) THEN 
     754                        ztest_2 = 1 
     755                     ELSE 
     756                        ! this write is useful 
     757                        !WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, & 
     758                        !    ' zvt_i_ini = ', zvt_i_ini(ji,jj) 
     759                        !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
     760                        !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
     761                        !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
     762                        !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
     763                        !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
     764                        !WRITE(numout,*) ' hi_max ',hi_max 
     765                        !WRITE(numout,*) ' jl0 = ',jl0 
     766                        ztest_2 = 0 
     767                     ENDIF 
     768 
     769                     ! Test 3: thickness of the last category is in-bounds ?  
     770                     IF ( zht_i_ini(i_fill, ji,jj) .GT. hi_max(i_fill-1) ) THEN 
     771                     ztest_3 = 1 
     772                     ELSE 
     773                     ! this write is useful 
     774                     !WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zht_i_ini(i_fill,ji,jj) = ', & 
     775                     !zht_i_ini(i_fill,ji,jj), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 
     776                     !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
     777                     !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
     778                     !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
     779                     !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
     780                     !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
     781                     !WRITE(numout,*) ' hi_max ',hi_max 
     782                     !WRITE(numout,*) ' jl0 = ',jl0 
     783                     ztest_3 = 0 
     784                     ENDIF 
     785 
     786                     ! Test 4: positivity of ice concentrations 
     787                     ztest_4 = 1 
     788                     DO jl = 1, jpl 
     789                     IF ( za_i_ini(jl,ji,jj) .LT. 0._wp ) THEN 
     790                        ! this write is useful 
     791                        !WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, 'WITH A = ', za_i_ini(jl,ji,jj) 
     792                        !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
     793                        !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
     794                        !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
     795                        !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
     796                        !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
     797                        !WRITE(numout,*) ' hi_max ',hi_max 
     798                        !WRITE(numout,*) ' jl0 = ',jl0 
     799                        !WRITE(numout,*) 
     800                        ztest_4 = 0 
     801                     ENDIF 
     802                     END DO 
     803 
     804                  ENDIF ! ztest_1 + ztest_2 + ztest_3 + ztest_4 
     805 
     806                  ztests = ztest_1 + ztest_2 + ztest_3 + ztest_4 
     807 
     808               END DO ! i_fill 
     809 
     810               !WRITE(numout,*) ' ztests : ', ztests 
     811               !IF ( ztests .NE. 4 ) THEN 
     812               !WRITE(numout,*) 
     813               !WRITE(numout,*) ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' 
     814               !WRITE(numout,*) ' !!!! RED ALERT                  !!! ' 
     815               !WRITE(numout,*) ' !!!! BIIIIP BIIIP BIIIIP BIIIIP !!!' 
     816               !WRITE(numout,*) ' !!!! Something is wrong in the LIM3 initialization procedure ' 
     817               !WRITE(numout,*) ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' 
     818               !WRITE(numout,*) 'ji,jj,narea ',ji,jj,narea 
     819               !WRITE(numout,*) ' *** ztests is not equal to 4 ' 
     820               !WRITE(numout,*) ' *** ztest_i (i=1,4) = ', ztest_1, ztest_2,ztest_3,ztest_4 
     821               !WRITE(numout,*) ' zat_i_ini : ', zat_i_ini(ji,jj) 
     822               !WRITE(numout,*) ' zhm_i_ini : ', zhm_i_ini(ji,jj) 
     823               !WRITE(numout,*) ' zht_i_ini(:,jij,jj) ',zht_i_ini(:,ji,jj) 
     824               !WRITE(numout,*) ' za_i_ini(:,jij,jj) ',za_i_ini(:,ji,jj) 
     825               !WRITE(numout,*) ' hi_max ',hi_max 
     826               !ENDIF ! ztests .NE. 4 
     827 
     828            ENDIF  !  jl0 ne 1 
     829 
     830         ENDIF  !  zat_i_ini ne 0 
     831      END DO ! jj 
     832      END DO ! ji 
     833 
     834 
     835      !--------------------------------------------------------------------- 
     836      ! 3.3) Space-dependent arrays for ice state variables 
     837      !--------------------------------------------------------------------- 
     838 
     839      ! Ice concentration, thickness and volume, ice salinity, ice age, surface 
     840      ! temperature 
     841      DO jl = 1, jpl ! loop over categories 
     842         DO jj = 1, jpj 
     843            DO ji = 1, jpi 
     844               a_i(ji,jj,jl)   = zswitch(ji,jj) * za_i_ini (jl,ji,jj)  ! concentration 
     845               ht_i(ji,jj,jl)  = zswitch(ji,jj) * zht_i_ini(jl,ji,jj)   !ice thickness 
     846 
     847               IF( zhm_i_ini( ji,jj ) .GT. 0_wp )THEN ; ht_s(ji,jj,jl)  = ht_i(ji,jj,jl) * ( zhm_s_ini( ji,jj ) / zhm_i_ini( ji,jj ) ) 
     848               ELSE                                   ; ht_s(ji,jj,jl)  = 0._wp 
     849               ENDIF 
     850               sm_i(ji,jj,jl)  = zswitch(ji,jj) * zsm_i_ini(ji,jj) !+ (1._wp - zswitch(ji,jj) ) * rn_simin ! salinity 
     851               o_i(ji,jj,jl)   = zswitch(ji,jj) * 1._wp + ( 1._wp -zswitch(ji,jj) ) ! age 
     852               t_su(ji,jj,jl)  = sist_ini(ji,jj) 
     853 
     854               ! This case below should not be used if (ht_s/ht_i) is ok in 
     855               ! namelist 
     856               ! In case snow load is in excess that would lead to 
     857               ! transformation from snow to ice 
     858               ! Then, transfer the snow excess into the ice (different from 
     859               ! limthd_dh) 
     860               zdh = MAX( 0._wp, ( rhosn * ht_s(ji,jj,jl) + ( rhoic - rau0 ) *ht_i(ji,jj,jl) ) * r1_rau0 ) 
     861               ! recompute ht_i, ht_s avoiding out of bounds values 
     862               ht_i(ji,jj,jl) = MIN( hi_max(jl), ht_i(ji,jj,jl) + zdh ) 
     863               ht_s(ji,jj,jl) = MAX( 0._wp, ht_s(ji,jj,jl) - zdh * rhoic *r1_rhosn ) 
     864 
     865               ! ice volume, salt content, age content 
     866               v_i(ji,jj,jl)   = ht_i(ji,jj,jl) * a_i(ji,jj,jl)              !ice volume 
     867               v_s(ji,jj,jl)   = ht_s(ji,jj,jl) * a_i(ji,jj,jl)              !snow volume 
     868               smv_i(ji,jj,jl) = MIN( sm_i(ji,jj,jl) , sss_m(ji,jj) ) *v_i(ji,jj,jl) ! salt content 
     869               oa_i(ji,jj,jl)  = o_i(ji,jj,jl) * a_i(ji,jj,jl)               !age content 
     870            END DO ! ji 
     871         END DO ! jj 
     872      END DO ! jl 
     873 
     874      !cbr 
     875      DO jk = 1, nlay_s 
     876         DO  jl = 1, jpl ! loop over categories 
     877            !rbb t_s(:,:,1,jl) =  tbif_ini(:,:,1) 
     878            t_s(:,:,1,jl) =  tbif_ini(:,:,1)*zswitch(:,:)+ ( 1._wp - zswitch(:,:) ) * rt0 
     879         END DO ! jl 
     880      END DO ! jk 
     881 
     882      ! Snow temperature and heat content 
     883      DO jk = 1, nlay_s 
     884         DO jl = 1, jpl ! loop over categories 
     885            DO jj = 1, jpj 
     886               DO ji = 1, jpi 
     887!cbr???                   t_s(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rt0 
     888                   ! Snow energy of melting 
     889                   e_s(ji,jj,jk,jl) = zswitch(ji,jj) * rhosn * ( cpic * ( rt0 - t_s(ji,jj,jk,jl) ) + lfus ) 
     890 
     891                   ! Mutliply by volume, and divide by number of layers to get 
     892                   ! heat content in J/m2 
     893                   e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) *r1_nlay_s 
     894               END DO ! ji 
     895            END DO ! jj 
     896         END DO ! jl 
     897      END DO ! jk 
     898 
     899      ! Ice salinity, temperature and heat content 
     900      DO  jk = 1, nlay_i 
     901         DO jl = 1, jpl ! loop over categories 
     902            DO jj = 1, jpj 
     903               DO ji = 1, jpi 
     904!cbr???                   t_i(ji,jj,jk,jl) = zswitch(ji,jj) * ztm_i_ini(ji,jj) + ( 1._wp - zswitch(ji,jj) ) * rt0 
     905                   t_i(ji,jj,jk,jl) =  tbif_ini(ji,jj,2)*zswitch(ji,jj)+ ( 1._wp - zswitch(ji,jj) ) * rt0 
     906                   s_i(ji,jj,jk,jl) = zswitch(ji,jj) * zsm_i_ini(ji,jj) !+ ( 1._wp - zswitch(ji,jj) ) * rn_simin 
     907                   ztmelts          = - tmut * s_i(ji,jj,jk,jl) + rt0           !Melting temperature in K 
     908 
     909                   ! heat content per unit volume 
     910                   e_i(ji,jj,jk,jl) = zswitch(ji,jj) * rhoic * (   cpic    * ( ztmelts - t_i(ji,jj,jk,jl) ) & 
     911                      +   lfus    * ( 1._wp - (ztmelts-rt0) /MIN((t_i(ji,jj,jk,jl)-rt0),-epsi20) ) & 
     912                      -   rcp     * ( ztmelts - rt0 ) ) 
     913 
     914                   ! Mutliply by ice volume, and divide by number of layers to 
     915                   ! get heat content in J/m2 
     916                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i 
     917               END DO ! ji 
     918            END DO ! jj 
     919         END DO ! jl 
     920      END DO ! jk 
     921 
     922      !cbr tmp CALL wrk_dealloc(jpl,jpi,jpj, zht_i_ini, za_i_ini, zv_i_ini) 
     923      CALL wrk_dealloc(jpl,jpi,jpj, zv_i_ini) 
     924      CALL wrk_dealloc(    jpl,jpi,jpj,zht_i_ini,za_i_ini) 
     925      CALL wrk_dealloc(    jpi,jpj, zhm_i_ini, zat_i_ini, zvt_i_ini, zhm_s_ini,zsm_i_ini ) 
     926      CALL wrk_dealloc(    jpi,jpj,zidto ) 
     927 
     928  END SUBROUTINE limini_file 
     929 
     930 
     931  INTEGER FUNCTION alloc_lim_istate_init() 
     932      !!----------------------------------------------------------------------------- 
     933      !! 
     934      !! 
     935      !! 
     936      !! 
     937      !!----------------------------------------------------------------------------- 
     938      INTEGER :: ierr(1) 
     939      !!----------------------------------------------------------------------------- 
     940      ALLOCATE( hicif_ini(jpi,jpj) , hsnif_ini(jpi,jpj) , frld_ini(jpi,jpj) , sist_ini(jpi,jpj) , zswitch(jpi,jpj) , tbif_ini(jpi,jpj,3) , Stat=ierr(1) ) 
     941      alloc_lim_istate_init = MAXVAL(ierr) 
     942      IF( alloc_lim_istate_init /= 0 )   CALL ctl_warn( 'lim_istate_init: failed to allocate arrays') 
     943 
     944   END FUNCTION alloc_lim_istate_init 
    513945#else 
    514946   !!---------------------------------------------------------------------- 
  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r5602 r6772  
    11MODULE thd_ice 
     2#if defined key_lim3 
     3 
    24   !!====================================================================== 
    35   !!                       ***  MODULE thd_ice  *** 
     
    172174      ! 
    173175   END FUNCTION thd_ice_alloc 
    174     
     176 
     177#endif    
    175178   !!====================================================================== 
    176179END MODULE thd_ice 
  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90

    r6101 r6772  
    1717    
    1818   PUBLIC crs_dom_alloc  ! Called from crsini.F90 
    19    PUBLIC crs_dom_alloc1  ! Called from crsini.F90 
    20    PUBLIC crs_dom_alloc2  ! Called from crsini.F90 
    2119   PUBLIC dom_grid_glo    
    2220   PUBLIC dom_grid_crs  
     
    104102      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: e1v_crs, e2v_crs ! horizontal scale factors grid type V 
    105103      REAL(wp), DIMENSION(:,:),   ALLOCATABLE :: e1f_crs, e2f_crs ! horizontal scale factors grid type F 
    106       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_crs, e3u_crs, e3v_crs, e3f_crs, e3w_crs 
    107       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_crs, e3u_max_crs, e3v_max_crs, e3f_max_crs, e3w_max_crs 
     104 
     105      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ht_0_crs 
     106      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_0_crs, e3u_0_crs, e3v_0_crs, e3f_0_crs, e3w_0_crs 
     107      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_0_crs, e3u_max_0_crs, e3v_max_0_crs, e3f_max_0_crs, e3w_max_0_crs 
     108 
     109#if defined key_vvl 
     110      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_b_crs, e3u_b_crs, e3v_b_crs, e3f_b_crs, e3w_b_crs 
     111      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_n_crs, e3u_n_crs, e3v_n_crs, e3f_n_crs, e3w_n_crs 
     112      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_a_crs, e3u_a_crs, e3v_a_crs, e3f_a_crs, e3w_a_crs 
     113 
     114      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: e3t_max_n_crs, e3u_max_n_crs, e3v_max_n_crs, e3f_max_n_crs, e3w_max_n_crs 
     115#endif 
     116 
    108117       
    109118      ! Surface 
     
    116125      REAL(wp), DIMENSION(:,:),   ALLOCATABLE,SAVE :: ff_crs 
    117126      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 
     127 
     128      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE,SAVE :: gdept_0_crs, gdepu_0_crs, gdepv_0_crs, gdepw_0_crs 
     129#if defined key_vvl 
     130      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE,SAVE :: gdept_n_crs, gdepu_n_crs, gdepv_n_crs, gdepw_n_crs 
     131#endif 
    119132 
    120133      ! Weights 
     
    146159      REAL(wp)     ::  rfactxy  
    147160 
     161      INTEGER, DIMENSION(:)    , ALLOCATABLE      :: nfactx,nfacty 
     162 
     163 
    148164      ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields 
    149       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE      :: tsb_crs,tsn_crs,rab_crs_n 
     165      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE      :: tsb_crs,tsn_crs,tsa_crs,rab_crs_n 
    150166      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE      :: un_crs, vn_crs, wn_crs, rke_crs 
    151167      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE      :: ub_crs, vb_crs 
     
    161177      REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: fmmflx_crs 
    162178      REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: utau_crs, vtau_crs, taum_crs 
    163       REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: rnf_crs 
     179      REAL(wp), PUBLIC, DIMENSION(:,:)  , ALLOCATABLE :: rnf_crs,rnf_b_crs 
     180      REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: trc_i_crs,trc_o_crs 
     181      REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: sbc_trc_crs, sbc_trc_b_crs 
    164182 
    165183      REAL(wp), PUBLIC, DIMENSION(:,:,:) , ALLOCATABLE ::   uslp_crs, wslpi_crs          !: i_slope at U- and W-points 
     
    195213CONTAINS 
    196214    
    197    INTEGER FUNCTION crs_dom_alloc1() 
     215   INTEGER FUNCTION crs_dom_alloc() 
    198216      !!------------------------------------------------------------------- 
    199217      !!                     *** FUNCTION crs_dom_alloc *** 
     
    210228       &       mi0_crs (jpiglo_crs), mi1_crs (jpiglo_crs),  & 
    211229       &       mj0_crs (jpjglo_crs), mj1_crs (jpjglo_crs),  & 
    212        &       mig_crs (jpi_crs)   , mjg_crs (jpj_crs)   ,  STAT=ierr(1) )  
    213  
     230       &       mig_crs (jpi_crs)   , mjg_crs (jpj_crs)   ,  &  
     231       &       mis_crs (jpi_crs)   , mie_crs (jpi_crs)   ,  & 
     232       &       mjs_crs (jpj_crs)   , mje_crs (jpj_crs)   ,  & 
     233       &       nfactx  (jpi_crs)   , nfacty  (jpj_crs)   ,  & 
     234       &       nimppt_crs(jpnij) , nlcit_crs(jpnij) , nldit_crs(jpnij) , nleit_crs(jpnij) , & 
     235       &       nimppt_full(jpnij), nlcit_full(jpnij), nldit_full(jpnij), nleit_full(jpnij), & 
     236       &       njmppt_crs(jpnij) , nlcjt_crs(jpnij) , nldjt_crs(jpnij) , nlejt_crs(jpnij) , & 
     237       &       njmppt_full(jpnij), nlcjt_full(jpnij), nldjt_full(jpnij), nlejt_full(jpnij), & 
     238       &       nfiimpp_full(jpni,jpnj) , nfiimpp_crs(jpni,jpnj) , STAT=ierr(1) )  
    214239 
    215240      ! Set up Mask and Mesh 
     
    232257         &      e1e2t_crs(jpi_crs,jpj_crs), STAT=ierr(5)) 
    233258 
    234       ALLOCATE( e3t_crs(jpi_crs,jpj_crs,jpk)    , e3w_crs(jpi_crs,jpj_crs,jpk)    , &  
    235          &      e3u_crs(jpi_crs,jpj_crs,jpk)    , e3v_crs(jpi_crs,jpj_crs,jpk)    , & 
    236          &      e3f_crs(jpi_crs,jpj_crs,jpk)    , e1e2w_msk(jpi_crs,jpj_crs,jpk)  , &  
     259      ALLOCATE( e3t_0_crs(jpi_crs,jpj_crs,jpk)    , e3w_0_crs(jpi_crs,jpj_crs,jpk)    , & 
     260         &      e3u_0_crs(jpi_crs,jpj_crs,jpk)    , e3v_0_crs(jpi_crs,jpj_crs,jpk)    , & 
     261         &           ht_0_crs(jpi_crs,jpj_crs),                                     & 
     262#if defined key_vvl 
     263         &      e3t_b_crs(jpi_crs,jpj_crs,jpk)    , e3w_b_crs(jpi_crs,jpj_crs,jpk)    , & 
     264         &      e3u_b_crs(jpi_crs,jpj_crs,jpk)    , e3v_b_crs(jpi_crs,jpj_crs,jpk)    , & 
     265         &      e3t_n_crs(jpi_crs,jpj_crs,jpk)    , e3w_n_crs(jpi_crs,jpj_crs,jpk)    , & 
     266         &      e3u_n_crs(jpi_crs,jpj_crs,jpk)    , e3v_n_crs(jpi_crs,jpj_crs,jpk)    , & 
     267         &      e3t_a_crs(jpi_crs,jpj_crs,jpk)    , e3w_a_crs(jpi_crs,jpj_crs,jpk)    , & 
     268         &      e3u_a_crs(jpi_crs,jpj_crs,jpk)    , e3v_a_crs(jpi_crs,jpj_crs,jpk)    , & 
     269#endif 
     270         &      e1e2w_msk(jpi_crs,jpj_crs,jpk)  , & 
    237271         &      e2e3u_msk(jpi_crs,jpj_crs,jpk)  , e1e3v_msk(jpi_crs,jpj_crs,jpk)  , & 
    238272         &      e1e2w_crs(jpi_crs,jpj_crs,jpk)  , e2e3u_crs(jpi_crs,jpj_crs,jpk)  , & 
    239          &      e1e3v_crs(jpi_crs,jpj_crs,jpk)  , e3t_max_crs(jpi_crs,jpj_crs,jpk), & 
    240          &      e3w_max_crs(jpi_crs,jpj_crs,jpk), e3u_max_crs(jpi_crs,jpj_crs,jpk), & 
    241          &      e3v_max_crs(jpi_crs,jpj_crs,jpk), STAT=ierr(6)) 
     273         &      e1e3v_crs(jpi_crs,jpj_crs,jpk)  , & 
     274         &      e3t_max_0_crs(jpi_crs,jpj_crs,jpk), e3w_max_0_crs(jpi_crs,jpj_crs,jpk) , & 
     275         &      e3u_max_0_crs(jpi_crs,jpj_crs,jpk), e3v_max_0_crs(jpi_crs,jpj_crs,jpk) , & 
     276#if defined key_vvl 
     277         &      e3t_max_n_crs(jpi_crs,jpj_crs,jpk), e3w_max_n_crs(jpi_crs,jpj_crs,jpk) , & 
     278         &      e3u_max_n_crs(jpi_crs,jpj_crs,jpk), e3v_max_n_crs(jpi_crs,jpj_crs,jpk) , & 
     279#endif 
     280         &      STAT=ierr(6)) 
    242281 
    243282 
     
    255294         &      mbku_crs(jpi_crs,jpj_crs)  , mbkv_crs(jpi_crs,jpj_crs) , STAT=ierr(9)) 
    256295 
    257       ALLOCATE( gdept_crs(jpi_crs,jpj_crs,jpk), gdepu_crs(jpi_crs,jpj_crs,jpk) , & 
    258          &      gdepv_crs(jpi_crs,jpj_crs,jpk), gdepw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(10) ) 
     296      ALLOCATE( gdept_0_crs(jpi_crs,jpj_crs,jpk), gdepu_0_crs(jpi_crs,jpj_crs,jpk) , & 
     297         &      gdepv_0_crs(jpi_crs,jpj_crs,jpk), gdepw_0_crs(jpi_crs,jpj_crs,jpk) , & 
     298#if defined key_vvl 
     299         &      gdept_n_crs(jpi_crs,jpj_crs,jpk), gdepu_n_crs(jpi_crs,jpj_crs,jpk) , & 
     300         &      gdepv_n_crs(jpi_crs,jpj_crs,jpk), gdepw_n_crs(jpi_crs,jpj_crs,jpk) , & 
     301#endif 
     302         & STAT=ierr(10)) 
    259303 
    260304 
     
    270314 
    271315     ALLOCATE( sshb_crs(jpi_crs,jpj_crs), sshn_crs(jpi_crs,jpj_crs),  ssha_crs(jpi_crs,jpj_crs), & 
     316         &     qsr_crs(jpi_crs ,jpj_crs), wndm_crs(jpi_crs,jpj_crs), utau_crs(jpi_crs,jpj_crs) , & 
     317         &     vtau_crs(jpi_crs,jpj_crs), taum_crs(jpi_crs,jpj_crs),  & 
     318         &     rnf_crs (jpi_crs,jpj_crs), rnf_b_crs(jpi_crs ,jpj_crs), & 
    272319         &     emp_crs (jpi_crs,jpj_crs), emp_b_crs(jpi_crs,jpj_crs), & 
    273          &     qsr_crs(jpi_crs ,jpj_crs), wndm_crs(jpi_crs,jpj_crs), utau_crs(jpi_crs,jpj_crs) , & 
    274          &     vtau_crs(jpi_crs,jpj_crs), taum_crs(jpi_crs,jpj_crs), rnf_crs(jpi_crs ,jpj_crs), & 
     320         &     sbc_trc_crs (jpi_crs,jpj_crs,jpts), sbc_trc_b_crs(jpi_crs,jpj_crs,jpts), & 
     321         &     trc_i_crs (jpi_crs,jpj_crs,jpts), trc_o_crs(jpi_crs,jpj_crs,jpts), & 
    275322         &     fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs), fmmflx_crs(jpi_crs ,jpj_crs),  STAT=ierr(12)  ) 
    276323 
     
    285332#endif 
    286333 
    287      ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsb_crs(jpi_crs,jpj_crs,jpk,jpts),  & 
     334     ALLOCATE( tsb_crs(jpi_crs,jpj_crs,jpk,jpts), tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsa_crs(jpi_crs,jpj_crs,jpk,jpts),  & 
    288335               en_crs(jpi_crs,jpj_crs,jpk),   avt_crs(jpi_crs,jpj_crs,jpk),    & 
    289336# if defined key_zdfddm 
     
    295342         &      hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(15) ) 
    296343 
    297       crs_dom_alloc1 = MAXVAL(ierr) 
    298  
    299    END FUNCTION crs_dom_alloc1 
    300  
    301    INTEGER FUNCTION crs_dom_alloc() 
    302       !!------------------------------------------------------------------- 
    303       !!                     *** FUNCTION crs_dom_alloc *** 
    304       !!  ** Purpose :   Allocate public crs arrays   
    305       !!------------------------------------------------------------------- 
    306       !! Local variables 
    307       INTEGER, DIMENSION(2) :: ierr 
    308  
    309       ierr(:) = 0 
    310           
    311       ALLOCATE( nimppt_crs(jpnij) , nlcit_crs(jpnij) , nldit_crs(jpnij) , nleit_crs(jpnij), & 
    312        &  nimppt_full(jpnij) , nlcit_full(jpnij) , nldit_full(jpnij) , nleit_full(jpnij),   & 
    313                 njmppt_crs(jpnij) , nlcjt_crs(jpnij) , nldjt_crs(jpnij) , nlejt_crs(jpnij), & 
    314        &  njmppt_full(jpnij) , nlcjt_full(jpnij) , nldjt_full(jpnij) , nlejt_full(jpnij)  , STAT=ierr(1) ) 
    315  
    316       ALLOCATE( nfiimpp_full(jpni,jpnj) , nfiimpp_crs(jpni,jpnj) ,STAT=ierr(2) ) 
    317  
    318344      crs_dom_alloc = MAXVAL(ierr) 
    319345 
    320346   END FUNCTION crs_dom_alloc 
    321     
    322    INTEGER FUNCTION crs_dom_alloc2() 
    323       !!------------------------------------------------------------------- 
    324       !!                     *** FUNCTION crs_dom_alloc *** 
    325       !!  ** Purpose :   Allocate public crs arrays   
    326       !!------------------------------------------------------------------- 
    327       !! Local variables 
    328       INTEGER, DIMENSION(1) :: ierr 
    329  
    330       ierr(:) = 0 
    331        
    332       !cbr ALLOCATE( mjs_crs(nlej_crs) , mje_crs(nlej_crs), mis_crs(nlei_crs) , mie_crs(nlei_crs), STAT=ierr(1) ) 
    333       !cbr pk on alloue ac nlej_crs ?????? 
    334       !cbrALLOCATE( mjs_crs(nlcj_crs) , mje_crs(nlcj_crs), mis_crs(nlci_crs) , mie_crs(nlci_crs), STAT=ierr(1) ) 
    335       ALLOCATE( mjs_crs(jpj_crs) , mje_crs(jpj_crs), mis_crs(jpi_crs) , mie_crs(jpi_crs), STAT=ierr(1) ) 
    336       crs_dom_alloc2 = MAXVAL(ierr) 
    337  
    338       END FUNCTION crs_dom_alloc2 
    339347 
    340348   SUBROUTINE dom_grid_glo 
  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90

    r6101 r6772  
    3838   USE crslbclnk 
    3939   USE lib_mpp 
    40 !cbr   USE ieee_arithmetic    
     40   USE ieee_arithmetic    
    4141 
    4242   IMPLICIT NONE 
     
    6161 
    6262   SUBROUTINE crs_dom_msk 
     63   !!=================================================================== 
     64   ! 
     65   ! 
     66   ! 
     67   !!=================================================================== 
     68   INTEGER  ::  ji, jj, jk                   ! dummy loop indices 
     69   INTEGER  ::  ijis,ijie,ijjs,ijje 
     70   REAL(wp) ::  zmask 
     71   !!------------------------------------------------------------------- 
    6372       
    64       INTEGER  ::  ji, jj, jk                   ! dummy loop indices 
    65       INTEGER  ::  ijie,ijis,ijje,ijjs,ij,je_2 
    66       INTEGER  ::  iji, ijj 
    67       REAL(wp) ::  zmask 
    68       INTEGER  :: ir,jr 
    69        
    70       ! Initialize 
    71       tmask_crs(:,:,:) = 0.0 
    72       vmask_crs(:,:,:) = 0.0 
    73       umask_crs(:,:,:) = 0.0 
    74       fmask_crs(:,:,:) = 0.0 
    75       ! 
    76       DO jk = 1, jpkm1 
    77          DO ji = 2, nlei_crs 
    78             ijie = mie_crs(ji) 
    79             ijis = mis_crs(ji) 
    80  
    81             IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN     !!cc bande du sud style ORCA2 
    82  
    83                IF( mje_crs(2) - mjs_crs(2) == 1 )THEN 
    84  
    85                   jj = mje_crs(2) 
    86  
    87                   zmask = 0.0 
    88                   zmask = SUM( tmask(ijis:ijie,jj,jk) ) 
    89                   IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 
    90  
    91                   zmask = 0.0 
    92                   zmask = SUM( vmask(ijis:ijie,jj     ,jk) ) 
    93                   IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 
    94  
    95                   zmask = 0.0 
    96                   zmask = umask(ijie     ,jj,jk) 
    97                   IF( zmask > 0.0 )umask_crs(ji,2,jk) = 1.0 
    98  
    99                   fmask_crs(ji,jj,jk) = fmask(ijie,2,jk) 
    100                ENDIF 
    101             ELSE 
    102  
    103                jj   = mje_crs(2) 
    104                ij   = mjs_crs(2) 
    105  
    106                zmask = 0.0 
    107                zmask = SUM( tmask(ijis:ijie,ij:jj,jk) ) 
    108                IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 
    109  
    110                zmask = 0.0 
    111                zmask = SUM( vmask(ijis:ijie,jj     ,jk) ) 
    112                IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 
    113  
    114                zmask = 0.0 
    115                zmask = SUM(umask(ijie,ij:jj,jk)) 
    116                IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0 
    117  
    118                fmask_crs(ji,jj,jk) = fmask(ijie,2,jk) 
    119  
    120             ENDIF 
    121   
    122             DO jj = 3, nlej_crs 
    123                ijje = mje_crs(jj) 
    124                ijjs = mjs_crs(jj) 
    125  
    126                !iji=117 ; ijj=211 
    127                !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 
    128                !IF( ji ==iji .AND. jj==ijj .AND. jk==74 )THEN 
    129                !write(narea+5000,*)"mask ",ji,jj 
    130                !write(narea+5000,*)"mask ",ijie,ijis,ijjs,ijje 
    131                !ENDIF 
    132  
    133                ir=303-nimpp_crs+1 ; jr=302-njmpp_crs+1 
    134                IF( ji==ir .AND. jj==jr )THEN 
    135                    WRITE(narea+2000,*)"mask",ir,jr,ijis+nimpp-1,ijjs+njmpp-1 
    136                ENDIF 
    137  
    138                !IF( ijje .GT. jpj )WRITE(narea+200,*)"BUG",jj,ijjs,ijje,SHAPE(tmask) ; call flush(narea+200) 
    139                zmask = 0.0 
    140                zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 
    141                IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 
    142  
    143                zmask = 0.0 
    144                zmask = SUM( vmask(ijis:ijie,ijje     ,jk) ) 
    145                IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 
    146  
    147                zmask = 0.0 
    148                zmask = SUM( umask(ijie     ,ijjs:ijje,jk) ) 
    149                IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 
    150  
    151                fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) 
    152  
    153             ENDDO 
     73   ! Initialize 
     74   tmask_crs(:,:,:) = 0.0 
     75   vmask_crs(:,:,:) = 0.0 
     76   umask_crs(:,:,:) = 0.0 
     77   fmask_crs(:,:,:) = 0.0 
     78   ! 
     79   DO jk = 1, jpkm1 
     80      DO ji = nldi_crs, nlei_crs 
     81 
     82         ijis = mis_crs(ji) 
     83         ijie = mie_crs(ji) 
     84 
     85         DO jj = nldj_crs, nlej_crs 
     86 
     87            ijjs = mjs_crs(jj) 
     88            ijje = mje_crs(jj) 
     89 
     90            zmask = 0.0 
     91            zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 
     92            IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 
     93 
     94            zmask = 0.0 
     95            zmask = SUM( vmask(ijis:ijie,ijje     ,jk) ) 
     96            IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 
     97 
     98            zmask = 0.0 
     99            zmask = SUM( umask(ijie     ,ijjs:ijje,jk) ) 
     100            IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 
     101 
     102            fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) 
     103 
     104 
    154105         ENDDO 
    155106      ENDDO 
    156       CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) 
    157       !cbr 
    158       !DO ji=1,jpi_crs-1 
    159       !DO jj=1,jpj_crs-1 
    160       !DO jk=1,jpk 
    161       !   umask_crs(ji,jj,jk) = tmask_crs(ji  ,jj  ,jk) * tmask_crs(ji+1,jj  ,jk) 
    162       !   vmask_crs(ji,jj,jk) = tmask_crs(ji  ,jj  ,jk) * tmask_crs(ji  ,jj+1,jk) 
    163       !   fmask_crs(ji,jj,jk) = tmask_crs(ji  ,jj  ,jk) * tmask_crs(ji  ,jj+1,jk) *  tmask_crs(ji+1,jj  ,jk) *   tmask_crs(ji+1,jj+1,jk)  
    164       !ENDDO 
    165       !ENDDO 
    166       !ENDDO 
    167       ! 
    168       CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) 
    169       CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) 
    170       CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) 
    171       ! 
    172       !cbr 
    173       !DO ji=2,jpi_crs-1 
    174       !DO jj=2,jpj_crs-1 
    175       !DO jk=1,jpk 
    176       !   IF( tmask(ji-1,jj  ,jk)==1. .AND. tmask(ji  ,jj  ,jk)==1. .AND. umask(ji-1,jj  ,jk)==0. )WRITE(narea+5000,*)"MASK1",ji,jj,jk 
    177       !   IF( tmask(ji  ,jj  ,jk)==1. .AND. tmask(ji+1,jj  ,jk)==1. .AND. umask(ji  ,jj  ,jk)==0. )WRITE(narea+5000,*)"MASK2",ji,jj,jk 
    178       !   IF( tmask(ji  ,jj-1,jk)==1. .AND. tmask(ji  ,jj  ,jk)==1. .AND. vmask(ji  ,jj-1,jk)==0. )WRITE(narea+5000,*)"MASK3",ji,jj,jk 
    179       !   IF( tmask(ji  ,jj  ,jk)==1. .AND. tmask(ji  ,jj+1,jk)==1. .AND. vmask(ji  ,jj  ,jk)==0. )WRITE(narea+5000,*)"MASK4",ji,jj,jk 
    180       !   IF( umask(ji-1,jj  ,jk)==1. .AND. ( tmask(ji-1,jj  ,jk)==0. .OR. tmask(ji  ,jj  ,jk)==0. ) )WRITE(narea+5000,*)"MASK5",ji,jj,jk 
    181       !   IF( umask(ji  ,jj  ,jk)==1. .AND. ( tmask(ji  ,jj  ,jk)==0. .OR. tmask(ji+1,jj  ,jk)==0. ) )WRITE(narea+5000,*)"MASK6",ji,jj,jk 
    182       !   IF( vmask(ji  ,jj-1,jk)==1. .AND. ( tmask(ji  ,jj-1,jk)==0. .OR. tmask(ji  ,jj  ,jk)==0. ) )WRITE(narea+5000,*)"MASK7",ji,jj,jk 
    183       !   IF( vmask(ji  ,jj  ,jk)==1. .AND. ( tmask(ji  ,jj  ,jk)==0. .OR. tmask(ji  ,jj+1,jk)==0. ) )WRITE(narea+5000,*)"MASK8",ji,jj,jk 
    184       !ENDDO 
    185       !ENDDO 
    186       !ENDDO 
    187       ! 
     107   ENDDO 
     108 
     109   CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) 
     110   CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) 
     111   CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) 
     112   CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) 
     113   ! 
    188114   END SUBROUTINE crs_dom_msk 
    189115 
     
    219145      !! Local variables 
    220146      INTEGER :: ji, jj, jk                   ! dummy loop indices 
    221       INTEGER :: ijis, ijjs 
     147      INTEGER :: iji, ijj 
    222148      INTEGER  :: ir,jr 
     149      !!---------------------------------------------------------------- 
     150      p_gphi_crs(:,:)=0._wp 
     151      p_glam_crs(:,:)=0._wp 
    223152 
    224153   
     
    226155         CASE ( 'T' ) 
    227156            DO jj =  nldj_crs, nlej_crs 
    228                ijjs = mjs_crs(jj) + mybinctr 
    229                DO ji = 2, nlei_crs 
    230                   ijis = mis_crs(ji) + mxbinctr  
    231                   p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
    232                   p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
    233                   ir=303-nimpp_crs+1 ; jr=302-njmpp_crs+1 
    234                   WRITE(narea+2000,*)"coordT1",ir,jr 
    235                   IF( ji==ir .AND. jj==jr )THEN 
    236                      WRITE(narea+2000,*)"coordT",ir,jr,ijis+nimpp-1,ijjs+njmpp-1 
    237                   ENDIF 
     157               ijj = mjs_crs(jj) + 1 
     158               DO ji = nldi_crs, nlei_crs 
     159                  iji = mis_crs(ji) + 1 
     160                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 
     161                  p_glam_crs(ji,jj) = p_glam(iji,ijj) 
    238162               ENDDO 
    239163            ENDDO 
    240164         CASE ( 'U' ) 
    241165            DO jj =  nldj_crs, nlej_crs 
    242                ijjs = mjs_crs(jj) + mybinctr                   
    243                DO ji = 2, nlei_crs 
    244                   ijis = mis_crs(ji) 
    245                   p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
    246                   p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
     166               ijj = mjs_crs(jj) + 1 
     167               DO ji = nldi_crs, nlei_crs 
     168                  iji = mie_crs(ji) 
     169                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 
     170                  p_glam_crs(ji,jj) = p_glam(iji,ijj) 
     171  
    247172               ENDDO 
    248173            ENDDO 
    249174         CASE ( 'V' ) 
    250175            DO jj =  nldj_crs, nlej_crs 
    251                ijjs = mjs_crs(jj) 
    252                DO ji = 2, nlei_crs 
    253                   ijis = mis_crs(ji) + mxbinctr  
    254                   p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
    255                   p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
     176               ijj = mje_crs(jj) 
     177               DO ji = nldi_crs, nlei_crs 
     178                  iji = mis_crs(ji) + 1 
     179                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 
     180                  p_glam_crs(ji,jj) = p_glam(iji,ijj) 
    256181               ENDDO 
    257182            ENDDO 
    258183         CASE ( 'F' ) 
    259184            DO jj =  nldj_crs, nlej_crs 
    260                ijjs = mjs_crs(jj) 
    261                DO ji = 2, nlei_crs 
    262                   ijis = mis_crs(ji) 
    263                   p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
    264                   p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
     185               ijj = mje_crs(jj) 
     186               DO ji = nldi_crs, nlei_crs 
     187                  iji = mie_crs(ji) 
     188                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj) 
     189                  p_glam_crs(ji,jj) = p_glam(iji,ijj) 
    265190               ENDDO 
    266191            ENDDO 
     
    271196      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 ) 
    272197          
    273       ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 
    274       SELECT CASE ( cd_type ) 
    275          CASE ( 'T', 'V' ) 
    276             DO ji = 2, nlei_crs 
    277                ijis = mis_crs(ji) + mxbinctr  
    278                p_gphi_crs(ji,1) = p_gphi(ijis,1) 
    279                p_glam_crs(ji,1) = p_glam(ijis,1) 
    280             ENDDO 
    281          CASE ( 'U', 'F' ) 
    282             DO ji = 2, nlei_crs 
    283                ijis = mis_crs(ji)  
    284                p_gphi_crs(ji,1) = p_gphi(ijis,1) 
    285                p_glam_crs(ji,1) = p_glam(ijis,1) 
    286             ENDDO 
    287       END SELECT 
     198!cbr???      ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 
     199!      SELECT CASE ( cd_type ) 
     200!         CASE ( 'T', 'V' ) 
     201!            DO ji = 2, nlei_crs 
     202!               ijis = mis_crs(ji) + mxbinctr  
     203!               p_gphi_crs(ji,1) = p_gphi(ijis,1) 
     204!               p_glam_crs(ji,1) = p_glam(ijis,1) 
     205!            ENDDO 
     206!         CASE ( 'U', 'F' ) 
     207!            DO ji = 2, nlei_crs 
     208!               ijis = mis_crs(ji)  
     209!               p_gphi_crs(ji,1) = p_gphi(ijis,1) 
     210!               p_glam_crs(ji,1) = p_glam(ijis,1) 
     211!            ENDDO 
     212!      END SELECT 
    288213      ! 
    289214   END SUBROUTINE crs_dom_coordinates 
     
    317242      !! Local variables 
    318243      INTEGER :: ji, jj, jk     ! dummy loop indices 
    319       INTEGER :: ijie,ijje,ijrs 
     244      INTEGER :: ijis,ijie,ijjs,ijje 
     245      INTEGER :: ji1, jj1 
    320246   
    321247      !!----------------------------------------------------------------   
    322248      ! Initialize       
    323249 
    324       DO jk = 1, jpk     
    325          DO ji = 2, nlei_crs 
     250         DO ji = nldi_crs, nlei_crs 
     251 
     252            ijis = mis_crs(ji) 
    326253            ijie = mie_crs(ji) 
     254 
    327255            DO jj = nldj_crs, nlej_crs 
    328                ijje = mje_crs(jj)   ;   ijrs =  mje_crs(jj) - mjs_crs(jj) 
     256 
     257               ijjs = mjs_crs(jj) 
     258               ijje = mje_crs(jj) 
     259 
    329260               ! Only for a factro 3 coarsening 
    330261               SELECT CASE ( cd_type ) 
    331262                   CASE ( 'T' ) 
    332                       IF( ijrs == 0 .OR. ijrs == 1 ) THEN 
    333                         ! Si à la frontière sud on a pas assez de maille de la grille mère 
    334                          p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx 
    335                          p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty 
    336                       ELSE 
    337                          p_e1_crs(ji,jj) = p_e1(ijie-1,ijje-1) * nn_factx 
    338                          p_e2_crs(ji,jj) = p_e2(ijie-1,ijje-1) * nn_facty 
    339                       ENDIF 
     263                      !p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie     ,ijjs+1       ) ) 
     264                      !p_e2_crs(ji,jj) = SUM( p_e2(ijis+1        ,ijjs:ijje    ) ) 
     265                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1) 
     266                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1) 
    340267                   CASE ( 'U' ) 
    341                       IF( ijrs == 0 .OR. ijrs == 1 ) THEN 
    342                          ! Si à la frontière sud on a pas assez de maille de la grille mère 
    343                          p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                             
    344                          p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty 
    345                       ELSE 
    346                          p_e1_crs(ji,jj) = p_e1(ijie,ijje-1) * nn_factx 
    347                          p_e2_crs(ji,jj) = p_e2(ijie,ijje-1) * nn_facty 
    348                       ENDIF 
     268                      !p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijjs+1       ) ) 
     269                      !p_e2_crs(ji,jj) = SUM( p_e2(ijie          ,ijjs:ijje    ) ) 
     270                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1       )  
     271                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie  ,ijjs+1       )  
     272 
    349273                   CASE ( 'V' ) 
    350                          p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx                             
    351                          p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty 
     274                      !p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie     ,ijje         ) ) 
     275                      !p_e2_crs(ji,jj) = SUM( p_e2(ijis+1        ,ijjs+1:ijje+1) ) 
     276                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje       )  
     277                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1     )  
    352278                   CASE ( 'F' ) 
    353                          p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                             
    354                          p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty 
     279                      !p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijje         ) ) 
     280                      !p_e2_crs(ji,jj) = SUM( p_e2(ijie          ,ijjs+1:ijje+1) ) 
     281                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje       )  
     282                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie  ,ijjs+1     )  
    355283               END SELECT 
    356284            ENDDO 
    357285         ENDDO 
    358       ENDDO 
    359  
    360       CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pval=1.0 ) 
    361       CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pval=1.0 ) 
     286 
     287 
     288      CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 ) !cbr , pval=1.0 ) 
     289      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 ) !cbr , pval=1.0 ) 
    362290 
    363291   END SUBROUTINE crs_dom_hgr 
     
    416344      !! Local variables 
    417345      REAL(wp)                                :: zdAm 
    418       INTEGER                                 :: ji, jj, jk , ii, ij, je_2 
     346      INTEGER                                 :: ji, jj, jk 
     347      INTEGER :: ijis,ijie,ijjs,ijje 
    419348 
    420349      REAL(wp), DIMENSION(:,:,:), POINTER     :: zvol, zmask       
     
    427356 
    428357      DO jk = 1, jpk 
    429          zvol(:,:,jk) =  p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk)  
     358         zvol (:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk)  
     359         zmask(:,:,jk) = p_mask(:,:,jk)  
    430360      ENDDO 
    431361 
    432       zmask(:,:,:) = 0.0 
    433       !IF( cd_type == 'W' ) THEN 
    434       !   zmask(:,:,1) = p_mask(:,:,1)  
    435       !   DO jk = 2, jpk 
    436       !      zmask(:,:,jk) = p_mask(:,:,jk-1)  
    437       !   ENDDO 
    438       !ELSE 
    439          DO jk = 1, jpk 
    440              zmask(:,:,jk) = p_mask(:,:,jk)  
    441          ENDDO 
    442       !ENDIF 
    443  
    444       IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    445          IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    446             je_2 = mje_crs(2) 
    447             DO jk = 1, jpk            
    448                DO ji = nistr, niend, nn_factx 
    449                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    450                   p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  & 
    451                      &                 + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk)  
    452                   ! 
    453                   zdAm =  zvol(ji  ,je_2,jk) * zmask(ji  ,je_2,jk)  & 
    454                     &   + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk)  & 
    455                     &   + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk)  
    456                   !  
    457                   p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk)  
    458                ENDDO 
    459             ENDDO 
    460          ENDIF 
    461       ELSE 
    462          je_2 = mjs_crs(2) 
    463          DO jk = 1, jpk            
    464             DO ji = nistr, niend, nn_factx 
    465                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    466                p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  & 
    467                    &                + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk)  & 
    468                    &                + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk)   
    469               ! 
    470                zdAm = zvol(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk)  & 
    471                  &  + zvol(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk)  & 
    472                  &  + zvol(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk)  & 
    473                  &  + zvol(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk)  & 
    474                  &  + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk)  & 
    475                  &  + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk)  & 
    476                  &  + zvol(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk)  & 
    477                  &  + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk)  & 
    478                  &  + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) 
    479                  !  
    480                  p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk)  
    481             ENDDO 
    482          ENDDO 
    483       ENDIF 
    484  
    485       DO jk = 1, jpk            
    486          DO jj  = njstr, njend, nn_facty 
    487             DO ji = nistr, niend, nn_factx 
    488                ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    489                ij  = ( jj - njstr ) * rfacty_r + 3 
    490                ! 
    491                p_fld1_crs(ii,ij,jk) =  zvol(ji,jj  ,jk) + zvol(ji+1,jj  ,jk) + zvol(ji+2,jj  ,jk)  & 
    492                    &                 + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk)  & 
    493                    &                 + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk)  
    494                ! 
    495                zdAm =  zvol(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk)  & 
    496                  &   + zvol(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk)  & 
    497                  &   + zvol(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk)  & 
    498                  &   + zvol(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk)  & 
    499                  &   + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk)  & 
    500                  &   + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk)  & 
    501                  &   + zvol(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk)  & 
    502                  &   + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk)  & 
    503                  &   + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) 
    504                  !  
    505                 p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk)  
     362      DO jk = 1, jpk 
     363         DO ji = nldi_crs, nlei_crs 
     364 
     365            ijis = mis_crs(ji) 
     366            ijie = mie_crs(ji) 
     367 
     368            DO jj = nldj_crs, nlej_crs 
     369 
     370               ijjs = mjs_crs(jj) 
     371               ijje = mje_crs(jj) 
     372 
     373               p_fld1_crs(ji,jj,jk) =  SUM( zvol(ijis:ijie,ijjs:ijje,jk) ) 
     374               zdAm                 =  SUM( zvol(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) ) 
     375               p_fld2_crs(ji,jj,jk) = zdAm / p_fld1_crs(ji,jj,jk)  
    506376            ENDDO 
    507377         ENDDO 
     
    551421      REAL(wp),                                 INTENT(in)           :: psgn    ! sign  
    552422 
    553  
    554423      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity  
    555424 
    556425      !! Local variables 
    557426      INTEGER  :: ji, jj, jk  
    558       INTEGER  :: ii, ij, ijie, ijje, je_2 
     427      INTEGER  :: ijis, ijie, ijjs, ijje 
    559428      REAL(wp) :: zflcrs, zsfcrs    
    560429      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask,ztabtmp 
    561       INTEGER  :: iji, ijj 
    562430      INTEGER  :: ir,jr 
    563431      REAL(wp), DIMENSION(nn_factx,nn_facty):: ztmp 
     
    579447             
    580448               CASE( 'T', 'W' ) 
    581                   !IF( cd_type == 'T' ) THEN 
    582                      DO jk = 1, jpk 
    583                         zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk)  
    584                         zsurfmsk(:,:,jk) =  zsurf(:,:,jk)  
    585                     ENDDO 
    586                   !ELSE 
    587                   !  !cbr ???????????????????????????????? 
    588                   !   zsurf   (:,:,1) =  p_e12(:,:) * p_e3(:,:,1) 
    589                   !   zsurfmsk(:,:,1) =  zsurf(:,:,1) *  p_mask(:,:,1)  
    590                   !   DO jk = 2, jpk 
    591                   !      zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) 
    592                   !      zsurfmsk(:,:,jk) =  zsurf(:,:,jk) * p_mask(:,:,jk-1)  
    593                   !   ENDDO 
    594                   !ENDIF 
    595           
    596                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    597                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    598                         je_2 = mje_crs(2) 
    599                         DO jk = 1, jpk            
    600                            DO ji = nistr, niend, nn_factx 
    601                               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2        
    602                               zflcrs =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk)   & 
    603                                 &     + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk)   & 
    604                                 &     + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk)  
    605   
    606                               zsfcrs =  zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk)  
    607                               ! 
    608                               p_fld_crs(ii,2,jk) = zflcrs 
    609                               IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 
    610                            ENDDO 
    611                         ENDDO 
    612                      ENDIF 
    613                   ELSE 
    614                      je_2 = mjs_crs(2) 
    615                      DO jk = 1, jpk            
    616                         DO ji = nistr, niend, nn_factx 
    617                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    618                            zflcrs =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk) & 
    619                              &     + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk) & 
    620                              &     + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk) & 
    621                              &     + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk) & 
    622                              &     + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 
    623                              &     + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 
    624                              &     + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk) & 
    625                              &     + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 
    626                              &     + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk)  
    627  
    628                            zsfcrs =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) & 
    629                              &     + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 
    630                              &     + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk)  
    631                             ! 
    632                             p_fld_crs(ii,2,jk) = zflcrs 
    633                             IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 
    634                         ENDDO 
    635                      ENDDO 
    636                   ENDIF 
     449                  DO jk = 1, jpk 
     450                     zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk)  
     451                     zsurfmsk(:,:,jk) =  zsurf(:,:,jk)  
     452                  ENDDO 
    637453                  ! 
    638                   DO jk = 1, jpk            
    639                      DO jj  = njstr, njend, nn_facty 
    640                         DO ji = nistr, niend, nn_factx 
    641                            ii = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    642                            ij = ( jj - njstr ) * rfacty_r + 3 
    643                            zflcrs =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk) & 
    644                              &     + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk) & 
    645                              &     + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk) & 
    646                              &     + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk) & 
    647                              &     + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 
    648                              &     + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 
    649                              &     + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk) & 
    650                              &     + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 
    651                              &     + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk)  
    652                            zsfcrs =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk) & 
    653                              &     + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 
    654                              &     + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk)  
    655                             ! 
    656 !cbr                            IF( ieee_is_nan(p_fld_crs(ii,ij,jk))) THEN 
    657  
    658                            p_fld_crs(ii,ij,jk) = zflcrs 
    659                            IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 
     454                  DO jk = 1, jpk           
     455                     DO jj  = nldj_crs,nlej_crs 
     456                        ijjs = mjs_crs(jj) 
     457                        ijje = mje_crs(jj) 
     458                        DO ji = nldi_crs, nlei_crs 
     459 
     460                           ijis = mis_crs(ji) 
     461                           ijie = mie_crs(ji) 
     462 
     463                           zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     464                           zsfcrs = SUM(                                 zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     465 
     466                           p_fld_crs(ji,jj,jk) = zflcrs 
     467                           IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs 
    660468                        ENDDO       
    661469                     ENDDO 
    662470                  ENDDO   
     471                  ! 
    663472               CASE DEFAULT 
    664473                    STOP 
    665                END SELECT 
    666  
    667               CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
     474            END SELECT 
     475 
     476            CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
     477 
    668478         CASE ( 'LOGVOL' ) 
    669479 
    670480            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) 
    673481 
    674482            ztabtmp(:,:,:)=0._wp 
    675483            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) 
    677484            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) 
    679485 
    680486            SELECT CASE ( cd_type ) 
    681487 
    682488               CASE( 'T', 'W' ) 
    683                      DO jk = 1, jpk 
    684                         zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
    685                         zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
    686                     ENDDO 
    687  
    688                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    689                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    690                         je_2 = mje_crs(2) 
    691                         DO jk = 1, jpk 
    692                            DO ji = nistr, niend, nn_factx 
    693                               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    694                               zflcrs =  ztabtmp(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk)   & 
    695                                 &     + ztabtmp(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk)   & 
    696                                 &     + ztabtmp(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 
    697  
    698                               zsfcrs =  zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 
    699                               ! 
    700                               p_fld_crs(ii,2,jk) = 0._wp 
    701                               IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 
    702                               p_fld_crs(ii,2,jk) = 10 ** ( p_fld_crs(ii,2,jk) * p_mask_crs(ii,2,jk) ) * p_mask_crs(ii,2,jk) 
    703                            ENDDO 
    704                         ENDDO 
    705                      ENDIF 
    706                   ELSE 
    707                      je_2 = mjs_crs(2) 
    708                      DO jk = 1, jpk 
    709                         DO ji = nistr, niend, nn_factx 
    710                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    711                            zflcrs =  ztabtmp(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk) & 
    712                              &     + ztabtmp(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk) & 
    713                              &     + ztabtmp(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk) & 
    714                              &     + ztabtmp(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk) & 
    715                              &     + ztabtmp(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 
    716                              &     + ztabtmp(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 
    717                              &     + ztabtmp(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk) & 
    718                              &     + ztabtmp(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 
    719                              &     + ztabtmp(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 
    720  
    721                            zsfcrs =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) & 
    722                              &     + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 
    723                              &     + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 
    724                             ! 
    725                             p_fld_crs(ii,2,jk) = 0._wp 
    726                             IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 
    727                             p_fld_crs(ii,2,jk) = 10 ** ( p_fld_crs(ii,2,jk) * p_mask_crs(ii,2,jk) ) * p_mask_crs(ii,2,jk) 
     489 
     490                  DO jk = 1, jpk 
     491                     zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
     492                     zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
     493                  ENDDO 
     494                  ! 
     495                  DO jk = 1, jpk 
     496                     DO jj  = nldj_crs,nlej_crs 
     497                        ijjs = mjs_crs(jj) 
     498                        ijje = mje_crs(jj) 
     499                        DO ji = nldi_crs, nlei_crs 
     500                           ijis = mis_crs(ji) 
     501                           ijie = mie_crs(ji) 
     502                           zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     503                           zsfcrs = SUM(                                 zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     504                           p_fld_crs(ji,jj,jk) = zflcrs 
     505                           IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs 
     506                           p_fld_crs(ji,jj,jk) = 10 ** ( p_fld_crs(ji,jj,jk) *  p_mask_crs(ji,jj,jk) ) * p_mask_crs(ji,jj,jk) 
    728507                        ENDDO 
    729508                     ENDDO 
    730                   ENDIF 
     509                  ENDDO 
     510               CASE DEFAULT 
     511                    STOP 
     512            END SELECT 
     513 
     514            CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp ) 
     515 
     516         CASE ( 'MED' ) 
     517 
     518            CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
     519 
     520            SELECT CASE ( cd_type ) 
     521 
     522               CASE( 'T', 'W' ) 
     523                  DO jk = 1, jpk 
     524                     zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
     525                     zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
     526                  ENDDO 
    731527                  ! 
    732528                  DO jk = 1, jpk 
    733                      DO jj  = njstr, njend, nn_facty 
    734                         DO ji = nistr, niend, nn_factx 
    735                            ii = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    736                            ij = ( jj - njstr ) * rfacty_r + 3 
    737                            zflcrs =  ztabtmp(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk) & 
    738                              &     + ztabtmp(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk) & 
    739                              &     + ztabtmp(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk) & 
    740                              &     + ztabtmp(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk) & 
    741                              &     + ztabtmp(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 
    742                              &     + ztabtmp(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 
    743                              &     + ztabtmp(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk) & 
    744                              &     + ztabtmp(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 
    745                              &     + ztabtmp(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 
    746                            zsfcrs =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk) & 
    747                              &     + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 
    748                              &     + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 
    749                             ! 
    750                            p_fld_crs(ii,ij,jk) = 0._wp 
    751                            IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 
    752                            p_fld_crs(ii,ij,jk) = 10 ** ( p_fld_crs(ii,ij,jk) *  p_mask_crs(ii,ij,jk) ) * p_mask_crs(ii,ij,jk) 
    753                         ENDDO 
    754                      ENDDO 
    755                   ENDDO 
    756                CASE DEFAULT 
    757                     STOP 
    758                END SELECT 
    759  
    760  
    761               !WHERE( p_fld .NE. 0._wp ) p_fld=10**(p_fld) 
    762               !zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld)",zmin,zmax ; CALL flush(numout) 
    763               !p_fld = p_fld * p_mask 
    764               !zmin=MINVAL(p_fld) ; zmax=MAXVAL(p_fld);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld)*tmask",zmin,zmax ; CALL flush(numout) 
    765  
    766               zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"p_fld_crs",zmin,zmax; CALL flush(numout) 
    767               !p_fld_crs=10**(p_fld_crs*p_mask_crs) 
    768               !zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld_crs)",zmin,zmax; CALL flush(numout) 
    769               !p_fld_crs=p_fld_crs*p_mask_crs 
    770               !zmin=MINVAL(p_fld_crs) ; zmax=MAXVAL(p_fld_crs);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"10**(p_fld_crs)*tmask",zmin,zmax; CALL flush(numout) 
    771  
    772               CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp ) 
    773          CASE ( 'MED' ) 
    774  
    775             CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
    776  
    777             SELECT CASE ( cd_type ) 
    778  
    779                CASE( 'T', 'W' ) 
    780                      DO jk = 1, jpk 
    781                         zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
    782                         zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
    783                     ENDDO 
    784  
    785                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    786                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    787                         je_2 = mje_crs(2) 
    788                         DO jk = 1, jpk 
    789                            DO ji = nistr, niend, nn_factx 
    790                               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    791  
    792                               ztmp1(:) = 0._wp 
    793                               ztmp1(1:3) =  p_fld(ji:ji+2,je_2,jk) 
    794                               CALL PIKSRT(nn_factx*nn_facty,ztmp1) 
    795                               ir=0 
    796                               jr=1 
    797                               DO WHILE( jr .LE. nn_factx*nn_facty ) 
    798                                  IF( ztmp1(jr) == 0. )THEN 
    799                                     ir=jr 
    800                                     jr=jr+1 
    801                                  ELSE 
    802                                     EXIT 
    803                                  ENDIF 
    804                               ENDDO 
    805                               IF( ir .LE. nn_factx*nn_facty-1 )THEN 
    806                                  ALLOCATE( ztmp2(nn_factx*nn_facty-ir) ) 
    807                                  ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty) 
    808                                  jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1 
    809                                  p_fld_crs(ii,2,jk) = ztmp2(jr) 
    810                                  DEALLOCATE( ztmp2 ) 
    811                               ELSE 
    812                                  p_fld_crs(ii,ij,jk) = 0._wp 
    813                               ENDIF 
    814  
    815                            ENDDO 
    816                         ENDDO 
    817                      ENDIF 
    818                   ELSE 
    819                      je_2 = mjs_crs(2) 
    820                      DO jk = 1, jpk 
    821                         DO ji = nistr, niend, nn_factx 
    822                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    823                             
    824                            ztmp(:,:)= p_fld(ji:ji+2,je_2:je_2+2,jk) 
    825                            zdim1(1)=nn_factx*nn_facty 
     529                     DO jj  = nldj_crs,nlej_crs 
     530                        ijjs = mjs_crs(jj) 
     531                        ijje = mje_crs(jj) 
     532                        DO ji = nldi_crs, nlei_crs 
     533                           ijis = mis_crs(ji) 
     534                           ijie = mie_crs(ji) 
     535 
     536                           ztmp(:,:)= p_fld(ijis:ijie,ijjs:ijje,jk) 
     537                           zdim1(1) = nn_factx*nn_facty 
    826538                           ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 ) 
    827539                           CALL PIKSRT(nn_factx*nn_facty,ztmp1) 
     540 
    828541                           ir=0 
    829542                           jr=1 
     
    840553                              ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty) 
    841554                              jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1 
    842                               p_fld_crs(ii,2,jk) = ztmp2(jr) 
     555                              p_fld_crs(ji,jj,jk) = ztmp2(jr) 
    843556                              DEALLOCATE( ztmp2 ) 
    844557                           ELSE 
    845                            p_fld_crs(ii,ij,jk) = 0._wp 
     558                              p_fld_crs(ji,jj,jk) = 0._wp 
    846559                           ENDIF 
    847560 
    848561                        ENDDO 
    849562                     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 
    884563                  ENDDO 
    885564               CASE DEFAULT 
    886565                    STOP 
    887                END SELECT 
    888  
    889               CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
     566            END SELECT 
     567 
     568           CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
    890569  
    891570         CASE ( 'SUM' ) 
     
    893572            CALL wrk_alloc( jpi, jpj, jpk, zsurfmsk ) 
    894573 
    895             SELECT CASE ( cd_type ) 
    896               CASE( 'W' ) 
    897                   IF( PRESENT( p_e3 ) ) THEN 
    898                     !cbr ????????????? 
    899                     !zsurfmsk(:,:,1) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)  
    900                     !DO jk = 2, jpk 
    901                     !  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1)  
    902                     !ENDDO 
    903                     DO jk = 1, jpk 
    904                       zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)  
    905                     ENDDO 
    906                  ELSE 
    907                     !zsurfmsk(:,:,1) =  p_e12(:,:) * p_mask(:,:,1)  
    908                     !DO jk = 2, jpk 
    909                     !  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk-1)  
    910                     !ENDDO 
    911                     DO jk = 1, jpk 
    912                       zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk)  
    913                     ENDDO 
    914                  ENDIF 
    915               CASE DEFAULT 
    916                  IF( PRESENT( p_e3 ) ) THEN 
    917                     DO jk = 1, jpk 
    918                       zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)  
    919                     ENDDO 
    920                  ELSE 
    921                     DO jk = 1, jpk 
    922                       zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk)  
    923                     ENDDO 
    924                  ENDIF 
    925               END SELECT 
     574            IF( PRESENT( p_e3 ) ) THEN 
     575               DO jk = 1, jpk 
     576                  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)  
     577               ENDDO 
     578            ELSE 
     579               DO jk = 1, jpk 
     580                  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk)  
     581               ENDDO 
     582            ENDIF 
    926583 
    927584            SELECT CASE ( cd_type ) 
    928585             
    929586               CASE( 'T', 'W' ) 
    930           
    931                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    932                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    933                         je_2 = mje_crs(2) 
    934                         DO jk = 1, jpk            
    935                            DO ji = nistr, niend, nn_factx 
    936                               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2           
    937                               zflcrs  =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk) & 
    938                                 &      + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & 
    939                                 &      + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk)  
    940                                ! 
    941                               p_fld_crs(ii,2,jk) = zflcrs 
    942                            ENDDO 
    943                         ENDDO 
    944                       ENDIF 
    945                   ELSE 
    946                      je_2 = mjs_crs(2) 
    947                      DO jk = 1, jpk            
    948                         DO ji = nistr, niend, nn_factx 
    949                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    950                            zflcrs  =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk)  & 
    951                              &      + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk)  & 
    952                              &      + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk)  & 
    953                              &      + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk)  & 
    954                              &      + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk)  & 
    955                              &      + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk)  & 
    956                              &      + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk)  & 
    957                              &      + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk)  & 
    958                              &      + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk)   
    959                             ! 
    960                             p_fld_crs(ii,2,jk) = zflcrs 
     587         
     588                  DO jk = 1, jpk 
     589                     DO jj  = nldj_crs,nlej_crs 
     590                        ijjs = mjs_crs(jj) 
     591                        ijje = mje_crs(jj) 
     592                        DO ji = nldi_crs, nlei_crs 
     593                           ijis = mis_crs(ji) 
     594                           ijie = mie_crs(ji) 
     595 
     596                           p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
    961597                        ENDDO 
    962598                     ENDDO 
    963                   ENDIF 
    964                   ! 
    965                   DO jk = 1, jpk            
    966                      DO jj  = njstr, njend, nn_facty 
    967                         DO ji = nistr, niend, nn_factx 
    968                            ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    969                            ij  = ( jj - njstr ) * rfacty_r + 3 
    970                            zflcrs  =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk)  & 
    971                              &      + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk)  & 
    972                              &      + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk)  & 
    973                              &      + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk)  & 
    974                              &      + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk)  & 
    975                              &      + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk)  & 
    976                              &      + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk)  & 
    977                              &      + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk)  & 
    978                              &      + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk)   
    979                             ! 
    980                             p_fld_crs(ii,ij,jk) = zflcrs 
    981                             !  
    982                         ENDDO       
    983                      ENDDO 
    984                   ENDDO    
    985              
     599                  ENDDO 
     600 
    986601               CASE( 'V' ) 
    987602 
     603 
    988604                  DO jk = 1, jpk 
    989                      DO ji = nistr, niend, nn_factx 
    990                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    991                         IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN     !!cc bande du sud style ORCA2 
    992                            IF( mje_crs(2) - mjs_crs(2) == 1 )THEN 
    993                               jj = mje_crs(2) 
    994                               zflcrs  = p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk) & 
    995                                &      + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk) & 
    996                                &      + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk) 
    997  
    998                               !zsfcrs = zsurfmsk(ji  ,jj  ,jk) & 
    999                               ! &     + zsurfmsk(ji+1,jj  ,jk) & 
    1000                               ! &     + zsurfmsk(ji+2,jj  ,jk) 
    1001  
    1002                               !IF( zsfcrs == 0 ) THEN  ; p_fld_crs(ii,2,jk) = zflcrs 
    1003                               !ELSE                    ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 
    1004                               !ENDIF 
    1005                            ENDIF 
    1006                         ELSE 
    1007                            ijje = mje_crs(2) 
    1008                            zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) & 
    1009                              &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & 
    1010                              &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 
    1011                            ! 
    1012                            !zsfcrs =  zsurfmsk(ji  ,ijje,jk) & 
    1013                            !  &     + zsurfmsk(ji+1,ijje,jk) & 
    1014                            !  &     + zsurfmsk(ji+2,ijje,jk) 
    1015  
    1016                            p_fld_crs(ii,2,jk) = zflcrs 
    1017                            !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs 
    1018                            !ELSE                   ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 
    1019                            !ENDIF 
    1020  
    1021                         ENDIF 
    1022  
    1023                         DO jj = njstr, njend, nn_facty 
    1024                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    1025                            ij   = ( jj - njstr ) * rfacty_r + 3 
    1026                            ijje = mje_crs(ij) 
    1027                            ijie = mie_crs(ii) 
    1028                            !                   
    1029                            zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) & 
    1030                              &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & 
    1031                              &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk)  
    1032                            ! 
    1033                            !zsfcrs =  zsurfmsk(ji  ,ijje,jk)  & 
    1034                            !  &     + zsurfmsk(ji+1,ijje,jk)  & 
    1035                            !  &     + zsurfmsk(ji+2,ijje,jk)  
    1036  
    1037                            p_fld_crs(ii,ij,jk) = zflcrs 
    1038                            !cbr1 
    1039                !iji=117 ; ijj=210 
    1040                !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 
    1041                !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 
    1042                !WRITE(narea+5000,*)"OPE V =======> " 
    1043                !WRITE(narea+5000,*)ii,ij,jk 
    1044                !WRITE(narea+5000,*)ji,jj,ijje 
    1045                !WRITE(narea+5000,*)p_fld(ji  ,ijje,jk) 
    1046                !WRITE(narea+5000,*)p_fld(ji+1,ijje,jk) 
    1047                !WRITE(narea+5000,*)p_fld(ji+2,ijje,jk) 
    1048                !WRITE(narea+5000,*)zflcrs 
    1049                !ENDIF 
    1050  
    1051                            !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,ij,jk) = zflcrs 
    1052                            !ELSE                   ; p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 
    1053                            !ENDIF 
    1054                            ! 
    1055                !IF( ii==iji .AND. ij==ijj .AND. jk==74 )WRITE(narea+5000,*)" p_fld_crs(ii,ij,jk) = ", p_fld_crs(ii,ij,jk) 
     605                     DO jj  = nldj_crs,nlej_crs 
     606                        ijjs = mjs_crs(jj) 
     607                        ijje = mje_crs(jj) 
     608                        DO ji = nldi_crs, nlei_crs 
     609                           ijis = mis_crs(ji) 
     610                           ijie = mie_crs(ji) 
     611 
     612                           p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijje,jk) * zsurfmsk(ijis:ijie,ijje,jk) ) 
    1056613                        ENDDO 
    1057614                     ENDDO 
    1058615                  ENDDO 
    1059   
     616 
    1060617               CASE( 'U' ) 
    1061618 
    1062                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1063                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1064                         je_2 = mje_crs(2) 
    1065                         DO jk = 1, jpk            
    1066                            DO ji = nistr, niend, nn_factx 
    1067                               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
    1068                               ijie = mie_crs(ii) 
    1069                               zflcrs  =  p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk)   
    1070                               p_fld_crs(ii,2,jk) = zflcrs 
    1071                            ENDDO 
    1072                         ENDDO 
    1073                       ENDIF 
    1074                   ELSE 
    1075                      je_2 = mjs_crs(2) 
    1076                      DO jk = 1, jpk            
    1077                         DO ji = nistr, niend, nn_factx 
    1078                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    1079                            ijie = mie_crs(ii) 
    1080                            zflcrs =  p_fld(ijie,je_2  ,jk) * zsurfmsk(ijie,je_2  ,jk)  & 
    1081                              &     + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk)  & 
    1082                              &     + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk)  
    1083  
    1084                            p_fld_crs(ii,2,jk) = zflcrs 
     619                  DO jk = 1, jpk 
     620                     DO jj  = nldj_crs,nlej_crs 
     621                        ijjs = mjs_crs(jj) 
     622                        ijje = mje_crs(jj) 
     623                        DO ji = nldi_crs, nlei_crs 
     624                           ijis = mis_crs(ji) 
     625                           ijie = mie_crs(ji) 
     626 
     627                           p_fld_crs(ji,jj,jk) = SUM( p_fld(ijie,ijjs:ijje,jk) * zsurfmsk(ijie,ijjs:ijje,jk) ) 
    1085628                        ENDDO 
    1086629                     ENDDO 
    1087                   ENDIF 
    1088                   ! 
    1089                   DO jk = 1, jpk            
    1090                      DO jj  = njstr, njend, nn_facty 
    1091                         DO ji = nistr, niend, nn_factx 
    1092                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1093                            ij   = ( jj - njstr ) * rfacty_r + 3 
    1094                            ijie = mie_crs(ii) 
    1095                            zflcrs =  p_fld(ijie,jj  ,jk) * zsurfmsk(ijie,jj  ,jk)  & 
    1096                               &    + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk)  & 
    1097                               &    + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk)  
    1098                              ! 
    1099                            p_fld_crs(ii,ij,jk) = zflcrs 
    1100                            !  
    1101                         ENDDO       
    1102                      ENDDO 
    1103                   ENDDO    
     630                  ENDDO 
    1104631 
    1105632              END SELECT 
     
    1109636              ENDIF 
    1110637 
    1111          !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) end SUM = ",p_fld(17,5,74) 
    1112638              CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk ) 
    1113639 
     
    1116642            CALL wrk_alloc( jpi, jpj, jpk, zmask ) 
    1117643 
    1118             SELECT CASE ( cd_type ) 
    1119               CASE( 'W' ) 
    1120                   zmask(:,:,1) = p_mask(:,:,1)  
    1121                   DO jk = 2, jpk 
    1122                      zmask(:,:,jk) = p_mask(:,:,jk-1)  
    1123                   ENDDO 
    1124               CASE ( 'T' ) 
    1125                   DO jk = 1, jpk 
    1126                      zmask(:,:,jk) = p_mask(:,:,jk)  
    1127                   ENDDO 
    1128             END SELECT 
     644            DO jk = 1, jpk 
     645               zmask(:,:,jk) = p_mask(:,:,jk)  
     646            ENDDO 
    1129647 
    1130648            SELECT CASE ( cd_type ) 
    1131649             
    1132650               CASE( 'T', 'W' ) 
    1133           
    1134                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1135                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1136                         je_2 = mje_crs(2) 
    1137                         DO jk = 1, jpk            
    1138                            DO ji = nistr, niend, nn_factx 
    1139                               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2         
    1140                               zflcrs =  & 
    1141                                 & MAX( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) - ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  & 
    1142                                 &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  & 
    1143                                 &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  ) 
    1144                               ! 
    1145                               p_fld_crs(ii,2,jk) = zflcrs 
    1146                            ENDDO 
    1147                         ENDDO 
    1148                       ENDIF 
    1149                   ELSE 
    1150                      je_2 = mjs_crs(2) 
    1151                      DO jk = 1, jpk            
    1152                         DO ji = nistr, niend, nn_factx 
    1153                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    1154                            zflcrs =  & 
    1155                              & MAX( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) - ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  & 
    1156                              &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) - ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  & 
    1157                              &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) - ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  & 
    1158                              &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) - ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  & 
    1159                              &      p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) - ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf ,  & 
    1160                              &      p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) - ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf ,  & 
    1161                              &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) - ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  & 
    1162                              &      p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) - ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf ,  & 
    1163                              &      p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) - ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf   ) 
    1164                            ! 
    1165                            p_fld_crs(ii,2,jk) = zflcrs 
     651         
     652                  DO jk = 1, jpk 
     653                     DO jj  = nldj_crs,nlej_crs 
     654                        ijjs = mjs_crs(jj) 
     655                        ijje = mje_crs(jj) 
     656                        DO ji = nldi_crs, nlei_crs 
     657                           ijis = mis_crs(ji) 
     658                           ijie = mie_crs(ji) 
     659                           p_fld_crs(ji,jj,jk) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) - & 
     660                                                       & ( ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk))* r_inf )                ) 
    1166661                        ENDDO 
    1167662                     ENDDO 
    1168                   ENDIF 
    1169                   ! 
    1170                   DO jk = 1, jpk            
    1171                      DO jj  = njstr, njend, nn_facty 
    1172                         DO ji = nistr, niend, nn_factx 
    1173                            ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    1174                            ij  = ( jj - njstr ) * rfacty_r + 3 
    1175                            zflcrs =  & 
    1176                              & MAX( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) - ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  & 
    1177                              &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) - ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  & 
    1178                              &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) - ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  & 
    1179                              &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) - ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  & 
    1180                              &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  & 
    1181                              &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  & 
    1182                              &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) - ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  & 
    1183                              &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  & 
    1184                              &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   ) 
    1185                            ! 
    1186                            p_fld_crs(ii,ij,jk) = zflcrs 
    1187                            ! 
    1188                         ENDDO       
    1189                      ENDDO 
    1190                   ENDDO    
    1191              
     663                  ENDDO 
     664  
    1192665               CASE( 'V' ) 
    1193  
    1194 !                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1195 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1196 !                        ijje = mje_crs(2) 
    1197 !                      ENDIF 
    1198 !                  ELSE 
    1199 !                     ijje = mjs_crs(2) 
    1200 !                  ENDIF 
    1201 ! 
    1202 !                  DO jk = 1, jpk 
    1203 !                     DO ji = nistr, niend, nn_factx 
    1204 !                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1205 !                        zflcrs = & 
    1206 !                          & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1207 !                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1208 !                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 
    1209 !                          ! 
    1210 !                        p_fld_crs(ii,2,jk) = zflcrs 
    1211 !                     ENDDO 
    1212 !                  ENDDO 
    1213 !                  ! 
    1214 !                  DO jk = 1, jpk            
    1215 !                     DO jj  = njstr, njend, nn_facty 
    1216 !                        DO ji = nistr, niend, nn_factx 
    1217 !                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    1218 !                           ij  = ( jj - njstr ) * rfacty_r + 3 
    1219 !                           ijje = mje_crs(ij) 
    1220 !                           !                   
    1221 !                           zflcrs = & 
    1222 !                             & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1223 !                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1224 !                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 
    1225 !                           ! 
    1226 !                           p_fld_crs(ii,ij,jk) = zflcrs 
    1227 !                           ! 
    1228 !                        ENDDO       
    1229 !                     ENDDO 
    1230 !                  ENDDO    
    1231666                  CALL ctl_stop('MAX operator and V case not available') 
    1232667             
    1233668               CASE( 'U' ) 
    1234  
    1235 !                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1236 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1237 !                        je_2 = mje_crs(2) 
    1238 !                        DO jk = 1, jpk            
    1239 !                           DO ji = nistr, niend, nn_factx 
    1240 !                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
    1241 !                              ijie = mie_crs(ii) 
    1242 !                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  
    1243 !                              ! 
    1244 !                              p_fld_crs(ii,2,jk) = zflcrs 
    1245 !                            ENDDO 
    1246 !                        ENDDO 
    1247 !                      ENDIF 
    1248 !                  ELSE 
    1249 !                     je_2 = mjs_crs(2) 
    1250 !                     DO jk = 1, jpk            
    1251 !                        DO ji = nistr, niend, nn_factx 
    1252 !                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    1253 !                           ijie = mie_crs(ii) 
    1254 !                           zflcrs = & 
    1255 !                             & MAX( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  & 
    1256 !                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  & 
    1257 !                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  ) 
    1258 !                            ! 
    1259 !                           p_fld_crs(ii,2,jk) = zflcrs 
    1260 !                        ENDDO 
    1261 !                     ENDDO 
    1262 !                  ENDIF 
    1263 !                  ! 
    1264 !                  DO jk = 1, jpk            
    1265 !                     DO jj  = njstr, njend, nn_facty 
    1266 !                        DO ji = nistr, niend, nn_factx 
    1267 !                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1268 !                           ij   = ( jj - njstr ) * rfacty_r + 3 
    1269 !                           ijie = mie_crs(ii) 
    1270 !                           zflcrs =  & 
    1271 !                             & MAX( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  & 
    1272 !                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  & 
    1273 !                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf  ) 
    1274 !                           !  
    1275 !                           p_fld_crs(ii,ij,jk) = zflcrs 
    1276 !                           !  
    1277 !                        ENDDO       
    1278 !                     ENDDO 
    1279 !                  ENDDO    
    1280669                  CALL ctl_stop('MAX operator and U case not available') 
    1281670 
    1282               END SELECT 
    1283  
    1284               CALL wrk_dealloc( jpi, jpj, jpk, zmask ) 
     671            END SELECT 
     672 
     673            CALL wrk_dealloc( jpi, jpj, jpk, zmask ) 
    1285674 
    1286675         CASE ( 'MIN' )      !   Search the min of unmasked grid cells 
    1287676 
    1288677            CALL wrk_alloc( jpi, jpj, jpk, zmask ) 
    1289  
    1290             !SELECT CASE ( cd_type ) 
    1291             !  CASE( 'W' ) 
    1292             !      !cbr ????????????????????????????? 
    1293             !      zmask(:,:,1) = p_mask(:,:,1)  
    1294             !      DO jk = 2, jpk 
    1295             !         zmask(:,:,jk) = p_mask(:,:,jk-1)  
    1296             !      ENDDO 
    1297             !  CASE ( 'T' ) 
     678            DO jk = 1, jpk 
     679               zmask(:,:,jk) = p_mask(:,:,jk) 
     680            ENDDO 
     681 
     682            SELECT CASE ( cd_type ) 
     683 
     684               CASE( 'T', 'W' ) 
     685 
    1298686                  DO jk = 1, jpk 
    1299                      zmask(:,:,jk) = p_mask(:,:,jk)  
    1300                   ENDDO 
    1301             !END SELECT 
    1302  
    1303             SELECT CASE ( cd_type ) 
    1304  
    1305                CASE( 'T', 'W' ) 
    1306           
    1307                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1308                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1309                         je_2 = mje_crs(2) 
    1310                         DO jk = 1, jpk            
    1311                            DO ji = nistr, niend, nn_factx 
    1312                               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2         
    1313                               zflcrs =  & 
    1314                                 & MIN( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) + ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  & 
    1315                                 &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  & 
    1316                                 &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  ) 
    1317                               ! 
    1318                               p_fld_crs(ii,2,jk) = zflcrs 
    1319                            ENDDO 
    1320                         ENDDO 
    1321                       ENDIF 
    1322                   ELSE 
    1323                      je_2 = mjs_crs(2) 
    1324                      DO jk = 1, jpk            
    1325                         DO ji = nistr, niend, nn_factx 
    1326                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    1327                            zflcrs =  & 
    1328                              & MIN( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) + ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  & 
    1329                              &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) + ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  & 
    1330                              &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) + ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  & 
    1331                              &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) + ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  & 
    1332                              &      p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) + ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf ,  & 
    1333                              &      p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) + ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf ,  & 
    1334                              &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) + ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  & 
    1335                              &      p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) + ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf ,  & 
    1336                              &      p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf   ) 
    1337                            ! 
    1338                            p_fld_crs(ii,2,jk) = zflcrs 
     687                     DO jj  = nldj_crs,nlej_crs 
     688                        ijjs = mjs_crs(jj) 
     689                        ijje = mje_crs(jj) 
     690                        DO ji = nldi_crs, nlei_crs 
     691                           ijis = mis_crs(ji) 
     692                           ijie = mie_crs(ji) 
     693 
     694                           p_fld_crs(ji,jj,jk) = MINVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) + & 
     695                                                       & ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk)* r_inf )                ) 
    1339696                        ENDDO 
    1340697                     ENDDO 
    1341                   ENDIF 
    1342                   ! 
    1343                   DO jk = 1, jpk            
    1344                      DO jj  = njstr, njend, nn_facty 
    1345                         DO ji = nistr, niend, nn_factx 
    1346                            ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    1347                            ij  = ( jj - njstr ) * rfacty_r + 3 
    1348                            zflcrs =  & 
    1349                              & MIN( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) + ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  & 
    1350                              &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) + ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  & 
    1351                              &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) + ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  & 
    1352                              &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) + ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  & 
    1353                              &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  & 
    1354                              &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  & 
    1355                              &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) + ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  & 
    1356                              &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  & 
    1357                              &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   ) 
    1358                            ! 
    1359                            p_fld_crs(ii,ij,jk) = zflcrs 
    1360                            ! 
    1361                         ENDDO       
    1362                      ENDDO 
    1363                   ENDDO    
     698                  ENDDO 
     699 
    1364700             
    1365701               CASE( 'V' ) 
    1366  
    1367 !                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1368 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1369 !                        ijje = mje_crs(2) 
    1370 !                      ENDIF 
    1371 !                  ELSE 
    1372 !                     ijje = mjs_crs(2) 
    1373 !                  ENDIF 
    1374 ! 
    1375 !                  DO jk = 1, jpk 
    1376 !                     DO ji = nistr, niend, nn_factx 
    1377 !                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1378 !                        zflcrs = & 
    1379 !                          & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1380 !                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1381 !                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 
    1382 !                          ! 
    1383 !                        p_fld_crs(ii,2,jk) = zflcrs 
    1384 !                     ENDDO 
    1385 !                  ENDDO 
    1386 !                  ! 
    1387 !                  DO jk = 1, jpk            
    1388 !                     DO jj  = njstr, njend, nn_facty 
    1389 !                        DO ji = nistr, niend, nn_factx 
    1390 !                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    1391 !                           ij  = ( jj - njstr ) * rfacty_r + 3 
    1392 !                           ijje = mje_crs(ij) 
    1393 !                           zflcrs = & 
    1394 !                             & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1395 !                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  & 
    1396 !                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 
    1397 !                           ! 
    1398 !                           p_fld_crs(ii,ij,jk) = zflcrs 
    1399 !                           ! 
    1400 !                        ENDDO       
    1401 !                     ENDDO 
    1402 !                  ENDDO    
    1403702                  CALL ctl_stop('MIN operator and V case not available') 
    1404  
    1405703             
    1406704               CASE( 'U' ) 
    1407  
    1408 !                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1409 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1410 !                        je_2 = mje_crs(2) 
    1411 !                        DO jk = 1, jpk            
    1412 !                           DO ji = nistr, niend, nn_factx 
    1413 !                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
    1414 !                              ijie = mie_crs(ii) 
    1415 !                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  
    1416 !                              ! 
    1417 !                              p_fld_crs(ii,2,jk) = zflcrs 
    1418 !                            ENDDO 
    1419 !                        ENDDO 
    1420 !                      ENDIF 
    1421 !                  ELSE 
    1422 !                     je_2 = mjs_crs(2) 
    1423 !                     DO jk = 1, jpk            
    1424 !                        DO ji = nistr, niend, nn_factx 
    1425 !                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    1426 !                           ijie = mie_crs(ii) 
    1427 !                           zflcrs = & 
    1428 !                             & MIN( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  & 
    1429 !                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  & 
    1430 !                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  ) 
    1431 !                            ! 
    1432 !                           p_fld_crs(ii,2,jk) = zflcrs 
    1433 !                        ENDDO 
    1434 !                     ENDDO 
    1435 !                  ENDIF 
    1436 !                  ! 
    1437 !                  DO jk = 1, jpk            
    1438 !                     DO jj  = njstr, njend, nn_facty 
    1439 !                        DO ji = nistr, niend, nn_factx 
    1440 !                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1441 !                           ij   = ( jj - njstr ) * rfacty_r + 3 
    1442 !                           ijie = mie_crs(ii) 
    1443 !                           zflcrs = & 
    1444 !                             & MIN( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  & 
    1445 !                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  & 
    1446 !                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf  ) 
    1447 !                           !  
    1448 !                           p_fld_crs(ii,ij,jk) = zflcrs 
    1449 !                           !  
    1450 !                        ENDDO       
    1451 !                     ENDDO 
    1452 !                  ENDDO    
    1453705                  CALL ctl_stop('MIN operator and U case not available') 
    1454706           
     
    1459711         END SELECT 
    1460712         ! 
    1461          !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) avt lbc = ",p_fld(17,5,74) 
    1462713         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) 
    1463          !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) apr lbc = ",p_fld(17,5,74) 
    1464714         ! 
    1465715    END SUBROUTINE crs_dom_ope_3d 
     
    1504754      !! Local variables 
    1505755      INTEGER  :: ji, jj, jk                 ! dummy loop indices 
    1506       INTEGER  :: ijie, ijje, ii, ij, je_2 
     756      INTEGER ::  ijis, ijie, ijjs, ijje 
    1507757      REAL(wp) :: zflcrs, zsfcrs    
    1508758      REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk    
     
    1515765       
    1516766        CASE ( 'VOL' ) 
    1517        
     767 
    1518768            CALL wrk_alloc( jpi, jpj, zsurfmsk ) 
    1519769            zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 
    1520770 
    1521             IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1522                IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1523                   je_2 = mje_crs(2) 
    1524                   DO ji = nistr, niend, nn_factx 
    1525                      ii   = ( ji - mis_crs(2) ) * rfactx_r + 2        
    1526                      zflcrs =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2)   & 
    1527                        &     + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2)   & 
    1528                        &     + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2)  
    1529  
    1530                      zsfcrs =  zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2)  
    1531                      ! 
    1532                      p_fld_crs(ii,2) = zflcrs 
    1533                      IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs 
    1534                   ENDDO 
    1535                ENDIF 
    1536             ELSE 
    1537                je_2 = mjs_crs(2) 
    1538                DO ji = nistr, niend, nn_factx 
    1539                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2    
    1540                   zflcrs =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  ) & 
    1541                     &     + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  ) & 
    1542                     &     + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  ) & 
    1543                     &     + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1) & 
    1544                     &     + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & 
    1545                     &     + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & 
    1546                     &     + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2) & 
    1547                     &     + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & 
    1548                     &     + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2)  
    1549  
    1550                    zsfcrs =  zsurfmsk(ji,je_2  ) + zsurfmsk(ji+1,je_2  ) + zsurfmsk(ji+2,je_2  ) & 
    1551                      &     + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) & 
    1552                      &     + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2)  
    1553                     ! 
    1554                     p_fld_crs(ii,2) = zflcrs 
    1555                     IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs 
    1556                 ENDDO 
    1557             ENDIF 
    1558                   ! 
    1559             DO jj  = njstr, njend, nn_facty 
    1560                DO ji = nistr, niend, nn_factx 
    1561                   ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    1562                   ij  = ( jj - njstr ) * rfacty_r + 3 
    1563                   zflcrs =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  ) & 
    1564                     &     + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  ) & 
    1565                     &     + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  ) & 
    1566                     &     + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1) & 
    1567                     &     + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & 
    1568                     &     + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & 
    1569                     &     + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2) & 
    1570                     &     + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & 
    1571                     &     + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2)  
    1572    
    1573                   zsfcrs =  zsurfmsk(ji,jj  ) + zsurfmsk(ji+1,jj  ) + zsurfmsk(ji+2,jj  ) & 
    1574                     &     + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) & 
    1575                     &     + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2)  
    1576                    ! 
    1577                   p_fld_crs(ii,ij) = zflcrs 
    1578                   IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij) = zflcrs / zsfcrs 
    1579                ENDDO       
    1580             ENDDO 
    1581  
     771            DO jj  = nldj_crs,nlej_crs 
     772               ijjs = mjs_crs(jj) 
     773               ijje = mje_crs(jj) 
     774               DO ji = nldi_crs, nlei_crs 
     775                  ijis = mis_crs(ji) 
     776                  ijie = mie_crs(ji) 
     777 
     778                  zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) ) 
     779                  zsfcrs = SUM(                              zsurfmsk(ijis:ijie,ijjs:ijje) ) 
     780 
     781                  p_fld_crs(ji,jj) = zflcrs 
     782                  IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj) = zflcrs / zsfcrs 
     783               ENDDO 
     784            ENDDO 
    1582785            CALL wrk_dealloc( jpi, jpj, zsurfmsk ) 
     786            ! 
    1583787 
    1584788         CASE ( 'SUM' ) 
     
    1595799               CASE( 'T', 'W' ) 
    1596800 
    1597                    IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1598                       IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1599                          je_2 = mje_crs(2) 
    1600                          DO ji = nistr, niend, nn_factx 
    1601                             ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1602                             zflcrs  =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2) & 
    1603                               &      + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & 
    1604                               &      + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2)  
    1605                               ! 
    1606                              p_fld_crs(ii,2) = zflcrs 
    1607                          ENDDO 
    1608                       ENDIF 
    1609                    ELSE 
    1610                       je_2 = mjs_crs(2) 
    1611                       DO ji = nistr, niend, nn_factx 
    1612                          ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1613                          zflcrs  =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  )  & 
    1614                            &      + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  )  & 
    1615                            &      + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  )  & 
    1616                            &      + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1)  & 
    1617                            &      + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1)  & 
    1618                            &      + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1)  & 
    1619                            &      + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2)  & 
    1620                            &      + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2)  & 
    1621                            &      + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2)   
    1622                             ! 
    1623                             p_fld_crs(ii,2) = zflcrs 
    1624                       ENDDO 
    1625                    ENDIF 
    1626                    ! 
    1627                    DO jj = njstr, njend, nn_facty 
    1628                       DO ji = nistr, niend, nn_factx 
    1629                          ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1630                          ij   = ( jj - njstr ) * rfacty_r + 3 
    1631                          zflcrs  =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  )  & 
    1632                            &      + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  )  & 
    1633                            &      + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  )  & 
    1634                            &      + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1)  & 
    1635                            &      + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1)  & 
    1636                            &      + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1)  & 
    1637                            &      + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2)  & 
    1638                            &      + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2)  & 
    1639                            &      + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2)   
    1640                           ! 
    1641                           p_fld_crs(ii,ij) = zflcrs 
    1642                           !  
    1643                       ENDDO       
    1644                    ENDDO 
     801                  DO jj  = nldj_crs,nlej_crs 
     802                     ijjs = mjs_crs(jj) 
     803                     ijje = mje_crs(jj) 
     804                     DO ji = nldi_crs, nlei_crs 
     805                        ijis = mis_crs(ji) 
     806                        ijie = mie_crs(ji) 
     807                        p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) ) 
     808                     ENDDO 
     809                  ENDDO 
    1645810             
    1646811               CASE( 'V' ) 
    1647                    DO ji = nistr, niend, nn_factx 
    1648                       ii  = ( ji - mis_crs(2) ) * rfactx_r + 2 
    1649                       IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN     !!cc bande du sud style ORCA2 
    1650                          IF( mje_crs(2) - mjs_crs(2) == 1 )THEN 
    1651                             jj = mje_crs(2) 
    1652                             zflcrs  = p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  )  & 
    1653                              &      + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  )  & 
    1654                              &      + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  ) 
    1655                             p_fld_crs(ii,2) = zflcrs 
    1656                          ENDIF 
    1657                       ELSE 
    1658                          ijje = mje_crs(2) 
    1659                          zflcrs  = p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje)  & 
    1660                            &     + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje)  & 
    1661                            &     + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 
    1662                          ! 
    1663                          p_fld_crs(ii,2) = zflcrs 
    1664                       ENDIF 
    1665  
    1666                       DO jj = njstr, njend, nn_facty 
    1667                          ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    1668                          ij   = ( jj - njstr ) * rfacty_r + 3 
    1669                          ijje = mje_crs(ij) 
    1670                          ijie = mie_crs(ii) 
    1671                          !                   
    1672                          zflcrs  = p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje)  & 
    1673                           &      + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje)  & 
    1674                           &      + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 
    1675                          ! 
    1676                          p_fld_crs(ii,ij) = zflcrs 
    1677                          ! 
    1678                       ENDDO 
    1679                    ENDDO 
    1680              
     812 
     813                  DO jj  = nldj_crs,nlej_crs 
     814                     ijjs = mjs_crs(jj) 
     815                     ijje = mje_crs(jj) 
     816                     DO ji = nldi_crs, nlei_crs 
     817                        ijis = mis_crs(ji) 
     818                        ijie = mie_crs(ji) 
     819                        p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijje) * zsurfmsk(ijis:ijie,ijje) ) 
     820                     ENDDO 
     821                  ENDDO 
     822 
    1681823               CASE( 'U' ) 
    1682824 
    1683                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1684                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1685                         je_2 = mje_crs(2) 
    1686                         DO ji = nistr, niend, nn_factx 
    1687                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1688                            ijie = mie_crs(ii) 
    1689                            zflcrs  =  p_fld(ijie,je_2) * zsurfmsk(ijie,je_2)   
    1690                            p_fld_crs(ii,2) = zflcrs 
    1691                         ENDDO 
    1692                      ENDIF 
    1693                   ELSE 
    1694                      je_2 = mjs_crs(2) 
    1695                      DO ji = nistr, niend, nn_factx 
    1696                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1697                         ijie = mie_crs(ii) 
    1698                         zflcrs =  p_fld(ijie,je_2  ) * zsurfmsk(ijie,je_2  )  & 
    1699                           &     + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1)  & 
    1700                           &     + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2)  
    1701     
    1702                         p_fld_crs(ii,2) = zflcrs 
     825                  DO jj  = nldj_crs,nlej_crs 
     826                     ijjs = mjs_crs(jj) 
     827                     ijje = mje_crs(jj) 
     828                     DO ji = nldi_crs, nlei_crs 
     829                        ijis = mis_crs(ji) 
     830                        ijie = mie_crs(ji) 
     831                        p_fld_crs(ji,jj) = SUM( p_fld(ijie,ijjs:ijje) * zsurfmsk(ijie,ijjs:ijje) ) 
    1703832                     ENDDO 
    1704                  ENDIF 
    1705  
    1706                  DO jj = njstr, njend, nn_facty 
    1707                     DO ji = nistr, niend, nn_factx 
    1708                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1709                        ij   = ( jj - njstr ) * rfacty_r + 3 
    1710                        ijie = mie_crs(ii) 
    1711                        zflcrs =  p_fld(ijie,jj  ) * zsurfmsk(ijie,jj  )  & 
    1712                           &    + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1)  & 
    1713                           &    + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2)  
    1714                          ! 
    1715                        p_fld_crs(ii,ij) = zflcrs 
    1716                        !  
    1717                     ENDDO       
    1718                  ENDDO 
     833                  ENDDO 
    1719834 
    1720835              END SELECT 
     
    1731846             
    1732847               CASE( 'T', 'W' ) 
    1733    
    1734                    DO ji = nistr, niend, nn_factx 
    1735                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1736                       IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1737                          IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1738                             je_2 = mje_crs(2) 
    1739                             zflcrs =  & 
    1740                               & MAX( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) - ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  & 
    1741                               &      p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  & 
    1742                               &      p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  ) 
    1743                             ! 
    1744                             p_fld_crs(ii,2) = zflcrs 
    1745                          ENDIF 
    1746                       ELSE 
    1747                          je_2 = mjs_crs(2)  
    1748                          zflcrs =  & 
    1749                            &  MAX( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) - ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  & 
    1750                            &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) - ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  & 
    1751                            &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) - ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  & 
    1752                            &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) - ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  & 
    1753                            &       p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) - ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf ,  & 
    1754                            &       p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) - ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf ,  & 
    1755                            &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) - ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  & 
    1756                            &       p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) - ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf ,  & 
    1757                            &       p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) - ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf   ) 
    1758                          ! 
    1759                          p_fld_crs(ii,2) = zflcrs 
    1760                       ENDIF 
    1761  
    1762                       DO jj = njstr, njend, nn_facty 
    1763                          ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1764                          ij   = ( jj - njstr ) * rfacty_r + 3 
    1765                          zflcrs = & 
    1766                           &  MAX( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) - ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  & 
    1767                           &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) - ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  & 
    1768                           &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) - ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  & 
    1769                           &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) - ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  & 
    1770                           &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  & 
    1771                           &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  & 
    1772                           &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) - ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  & 
    1773                           &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  & 
    1774                           &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   ) 
    1775                          ! 
    1776                          p_fld_crs(ii,ij) = zflcrs 
    1777                          ! 
    1778                       ENDDO       
    1779                    ENDDO 
     848  
     849                  DO jj  = nldj_crs,nlej_crs 
     850                     ijjs = mjs_crs(jj) 
     851                     ijje = mje_crs(jj) 
     852                     DO ji = nldi_crs, nlei_crs 
     853                        ijis = mis_crs(ji) 
     854                        ijie = mie_crs(ji) 
     855                        p_fld_crs(ji,jj) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) - & 
     856                                                 & ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) )                    ) 
     857                     ENDDO 
     858                  ENDDO 
    1780859             
    1781860               CASE( 'V' ) 
    1782  
    1783 !                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1784 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1785 !                        ijje = mje_crs(2) 
    1786 !                      ENDIF 
    1787 !                  ELSE 
    1788 !                     ijje = mjs_crs(2) 
    1789 !                  ENDIF 
    1790 ! 
    1791 !                  DO ji = nistr, niend, nn_factx 
    1792 !                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1793 !                     zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1794 !                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1795 !                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 
    1796 !                       ! 
    1797 !                     p_fld_crs(ii,2) = zflcrs 
    1798 !                  ENDDO       
    1799 !                  DO jj = njstr, njend, nn_facty 
    1800 !                     DO ji = nistr, niend, nn_factx 
    1801 !                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1802 !                        ij   = ( jj - njstr ) * rfacty_r + 3                
    1803 !                        ijje = mje_crs(ij)  
    1804 !                        !                   
    1805 !                        zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1806 !                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1807 !                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 
    1808 !                        ! 
    1809 !                        p_fld_crs(ii,ij) = zflcrs 
    1810 !                        ! 
    1811 !                     ENDDO       
    1812 !                  ENDDO 
    1813861                  CALL ctl_stop('MAX operator and V case not available') 
    1814862             
    1815863               CASE( 'U' ) 
    1816  
    1817 !                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1818 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1819 !                        je_2 = mje_crs(2) 
    1820 !                        DO ji = nistr, niend, nn_factx 
    1821 !                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1822 !                           ijie = mie_crs(ii) 
    1823 !                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf  
    1824 !                           p_fld_crs(ii,2) = zflcrs 
    1825 !                        ENDDO 
    1826 !                     ENDIF 
    1827 !                 ELSE 
    1828 !                     je_2 = mjs_crs(2) 
    1829 !                     DO ji = nistr, niend, nn_factx 
    1830 !                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1831 !                        ijie = mie_crs(ii) 
    1832 !                        zflcrs =  & 
    1833 !                          &  MAX( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  & 
    1834 !                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  & 
    1835 !                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf  ) 
    1836 !                        p_fld_crs(ii,2) = zflcrs 
    1837 !                     ENDDO 
    1838 !                 ENDIF 
    1839 !                 DO jj = njstr, njend, nn_facty 
    1840 !                    DO ji = nistr, niend, nn_factx 
    1841 !                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1842 !                       ij   = ( jj - njstr ) * rfacty_r + 3 
    1843 !                       ijie = mie_crs(ii) 
    1844 !                       zflcrs =  & 
    1845 !                         &  MAX( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  & 
    1846 !                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  & 
    1847 !                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf  ) 
    1848 !                        p_fld_crs(ii,ij) = zflcrs 
    1849 !                        !  
    1850 !                     ENDDO       
    1851 !                  ENDDO 
    1852864                  CALL ctl_stop('MAX operator and U case not available') 
    1853865 
     
    1859871 
    1860872              CASE( 'T', 'W' ) 
    1861    
    1862                    IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1863                       IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1864                          je_2 = mje_crs(2) 
    1865                          DO ji = nistr, niend, nn_factx 
    1866                             ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1867                             zflcrs =  & 
    1868                               & MIN( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) + ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  & 
    1869                              &       p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  & 
    1870                              &       p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  ) 
    1871                             ! 
    1872                             p_fld_crs(ii,2) = zflcrs 
    1873                          ENDDO 
    1874                       ENDIF 
    1875                    ELSE 
    1876                       DO ji = nistr, niend, nn_factx 
    1877                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1878                       je_2 = mjs_crs(2)  
    1879                       zflcrs =  & 
    1880                         &  MIN( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) + ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  & 
    1881                         &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) + ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  & 
    1882                         &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) + ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  & 
    1883                         &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) + ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  & 
    1884                         &       p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) + ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf ,  & 
    1885                         &       p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) + ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf ,  & 
    1886                         &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) + ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  & 
    1887                         &       p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) + ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf ,  & 
    1888                         &       p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) + ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf   ) 
    1889                       ! 
    1890                       p_fld_crs(ii,2) = zflcrs 
    1891                       ENDDO 
    1892                    ENDIF 
    1893  
    1894                    DO jj = njstr, njend, nn_facty 
    1895                       DO ji = nistr, niend, nn_factx 
    1896                          ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1897                          ij   = ( jj - njstr ) * rfacty_r + 3 
    1898                          zflcrs = & 
    1899                           &  MIN( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) + ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  & 
    1900                           &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) + ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  & 
    1901                           &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) + ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  & 
    1902                           &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) + ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  & 
    1903                           &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  & 
    1904                           &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  & 
    1905                           &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) + ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  & 
    1906                           &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  & 
    1907                           &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   ) 
    1908                          ! 
    1909                          p_fld_crs(ii,ij) = zflcrs 
    1910                          ! 
    1911                       ENDDO       
    1912                    ENDDO 
     873 
     874                  DO jj  = nldj_crs,nlej_crs 
     875                     ijjs = mjs_crs(jj) 
     876                     ijje = mje_crs(jj) 
     877                     DO ji = nldi_crs, nlei_crs 
     878                        ijis = mis_crs(ji) 
     879                        ijie = mie_crs(ji) 
     880                        p_fld_crs(ji,jj) = MINVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) + & 
     881                                                 & ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) )                    ) 
     882                     ENDDO 
     883                  ENDDO 
    1913884             
    1914885               CASE( 'V' ) 
    1915  
    1916 !                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1917 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1918 !                        ijje = mje_crs(2) 
    1919 !                      ENDIF 
    1920 !                  ELSE 
    1921 !                     ijje = mjs_crs(2) 
    1922 !                  ENDIF 
    1923 ! 
    1924 !                  DO ji = nistr, niend, nn_factx 
    1925 !                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1926 !                     zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1927 !                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1928 !                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 
    1929 !                       ! 
    1930 !                     p_fld_crs(ii,2) = zflcrs 
    1931 !                  ENDDO       
    1932 !                  DO jj = njstr, njend, nn_facty 
    1933 !                     DO ji = nistr, niend, nn_factx 
    1934 !                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1935 !                        ij   = ( jj - njstr ) * rfacty_r + 3                
    1936 !                        ijje = mje_crs(ij)  
    1937 !                        !                   
    1938 !                        zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1939 !                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  & 
    1940 !                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 
    1941 !                        ! 
    1942 !                        p_fld_crs(ii,ij) = zflcrs 
    1943 !                        ! 
    1944 !                     ENDDO       
    1945 !                  ENDDO 
    1946886                  CALL ctl_stop('MIN operator and V case not available') 
    1947887             
    1948888               CASE( 'U' ) 
    1949  
    1950 !                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    1951 !                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    1952 !                        je_2 = mje_crs(2) 
    1953 !                        DO ji = nistr, niend, nn_factx 
    1954 !                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1955 !                           ijie = mie_crs(ii) 
    1956 !                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf  
    1957 !  
    1958 !                           p_fld_crs(ii,2) = zflcrs 
    1959 !                        ENDDO 
    1960 !                     ENDIF 
    1961 !                 ELSE 
    1962 !                     je_2 = mjs_crs(2) 
    1963 !                     DO ji = nistr, niend, nn_factx 
    1964 !                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
    1965 !                        ijie = mie_crs(ii) 
    1966 !                        zflcrs =  & 
    1967 !                          &  MIN( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  & 
    1968 !                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  & 
    1969 !                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf  ) 
    1970 !                        p_fld_crs(ii,2) = zflcrs 
    1971 !                     ENDDO 
    1972 !                 ENDIF 
    1973 !                 DO jj = njstr, njend, nn_facty 
    1974 !                    DO ji = nistr, niend, nn_factx 
    1975 !                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
    1976 !                       ij   = ( jj - njstr ) * rfacty_r + 3 
    1977 !                       ijie = mie_crs(ii) 
    1978 !                       zflcrs =  & 
    1979 !                         &  MIN( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  & 
    1980 !                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  & 
    1981 !                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf  ) 
    1982 !                        p_fld_crs(ii,ij) = zflcrs 
    1983 !                        !  
    1984 !                     ENDDO       
    1985 !                  ENDDO 
    1986889                  CALL ctl_stop('MIN operator and U case not available') 
    1987890 
     
    1994897   END SUBROUTINE crs_dom_ope_2d 
    1995898 
    1996    SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs) 
     899   SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_2d_crs,  p_sfc_3d_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs) 
    1997900      !!----------------------------------------------------------------   
     901      !! 
     902      !! 
     903      !! 
     904      !! 
     905      !!---------------------------------------------------------------- 
    1998906      !!  Arguments 
    1999       CHARACTER(len=1),                         INTENT(in) :: cd_type      ! grid type T, W ( U, V, F) 
    2000       REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_mask       ! Parent grid T mask 
    2001       REAL(wp), DIMENSION(jpi,jpj)    ,         INTENT(in) :: p_e1, p_e2   ! 2D tracer T or W on parent grid 
    2002       REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_e3         ! 3D tracer T or W on parent grid 
    2003       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity 
    2004       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity  
    2005       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity  
     907      CHARACTER(len=1),                         INTENT(in)          :: cd_type           ! grid type T, W ( U, V, F) 
     908      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)          :: p_mask            ! Parent grid T mask 
     909      REAL(wp), DIMENSION(jpi,jpj)    ,         INTENT(in)          :: p_e1, p_e2        ! 2D tracer T or W on parent grid 
     910      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)          :: p_e3              ! 3D tracer T or W on parent grid 
     911      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(in),OPTIONAL :: p_sfc_2d_crs      ! Coarse grid box east or north face quantity 
     912      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in),OPTIONAL :: p_sfc_3d_crs      ! Coarse grid box east or north face quantity 
     913      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)       :: p_e3_crs          ! Coarse grid box east or north face quantity  
     914      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)       :: p_e3_max_crs      ! Coarse grid box east or north face quantity  
    2006915 
    2007916      !! Local variables 
    2008917      INTEGER ::  ji, jj, jk                   ! dummy loop indices 
    2009       INTEGER ::  ijie, ijje, ii, ij, je_2 
     918      INTEGER ::  ijis, ijie, ijjs, ijje  
    2010919      REAL(wp) :: ze3crs   
    2011       !REAL(wp), DIMENSION(:,:,:), POINTER :: zmask, zsurf    
    2012920 
    2013921      !!----------------------------------------------------------------   
    2014  
    2015        p_e3_crs    (:,:,:) = 0. 
    2016        p_e3_max_crs(:,:,:) = 1. 
     922      p_e3_crs    (:,:,:) = 0._wp 
     923      p_e3_max_crs(:,:,:) = 0._wp 
    2017924    
    2018925 
    2019        !CALL wrk_alloc( jpi, jpj, jpk, zmask, zsurf ) 
    2020  
    2021        SELECT CASE ( cd_type ) 
     926      SELECT CASE ( cd_type ) 
    2022927 
    2023928         CASE ('T') 
    2024929 
    2025             DO jk = 1 , jpk 
    2026                DO ji = nistr, niend, nn_factx 
    2027  
    2028                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2029                   IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2 
    2030  
    2031                   IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2032  
    2033                     jj = mje_crs(2) 
    2034  
    2035  
    2036                     ze3crs = MAX(  p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  & 
    2037                         &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  & 
    2038                         &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk)) 
    2039  
    2040                     p_e3_max_crs(ii,2,jk) = ze3crs 
    2041  
    2042                     ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  & 
    2043                         &     p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  & 
    2044                         &     p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) 
    2045  
    2046  
    2047                     p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2048                   ENDIF 
    2049                   ELSE 
    2050                      jj = mjs_crs(2) 
    2051  
    2052                      ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  & 
    2053                         &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  & 
    2054                         &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  & 
    2055                         &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk),  & 
    2056                         &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk),  & 
    2057                         &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  & 
    2058                         &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  & 
    2059                         &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  & 
    2060                         &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 
    2061  
    2062                      p_e3_max_crs(ii,2,jk) = ze3crs 
    2063  
    2064                      ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  & 
    2065                         &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  & 
    2066                         &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  & 
    2067                         &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk) +  & 
    2068                         &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk) +  & 
    2069                         &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  & 
    2070                         &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  & 
    2071                         &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  & 
    2072                         &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 
    2073  
    2074                        p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2075                   ENDIF 
    2076  
    2077                   DO jj = njstr, njend, nn_facty 
    2078                      ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    2079                      ij   = ( jj - njstr ) * rfacty_r + 3 
    2080                      ijje = mje_crs(ij) 
    2081                      ijie = mie_crs(ii) 
    2082                      !   
    2083                      ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  & 
    2084                         &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  & 
    2085                         &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  & 
    2086                         &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk),  & 
    2087                         &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk),  & 
    2088                         &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  & 
    2089                         &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  & 
    2090                         &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  & 
    2091                         &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 
    2092  
    2093                      p_e3_max_crs(ii,ij,jk) = ze3crs 
    2094                      ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  & 
    2095                         &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  & 
    2096                         &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  & 
    2097                         &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk) +  & 
    2098                         &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk) +  & 
    2099                         &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  & 
    2100                         &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  & 
    2101                         &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  & 
    2102                         &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 
    2103  
    2104                        p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 
     930            DO jk = 1, jpk 
     931               DO ji = nldi_crs, nlei_crs 
     932 
     933                  ijis = mis_crs(ji) 
     934                  ijie = mie_crs(ji) 
     935 
     936                  DO jj = nldj_crs, nlej_crs 
     937 
     938                     ijjs = mjs_crs(jj) 
     939                     ijje = mje_crs(jj) 
     940 
     941                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 
     942 
     943                     ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 
     944                     IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk) 
    2105945 
    2106946                  ENDDO 
     
    2110950         CASE ('U') 
    2111951 
    2112          DO jk = 1 , jpk 
    2113                DO ji = nistr, niend, nn_factx 
    2114                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2115                   IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2 
    2116  
    2117                      IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2118  
    2119                     jj = mje_crs(2) 
    2120  
    2121  
    2122                     ze3crs = p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk) 
    2123  
    2124                     p_e3_max_crs(ii,2,jk) = ze3crs 
    2125  
    2126                     ze3crs =  p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) 
    2127  
    2128  
    2129                      p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2130                      ENDIF 
    2131                   ELSE 
    2132                      jj = mjs_crs(2) 
    2133  
    2134                      ze3crs = MAX( p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  & 
    2135                                    p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  & 
    2136                                    p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 
    2137  
    2138                      p_e3_max_crs(ii,2,jk) = ze3crs 
    2139  
    2140                      ze3crs =  p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  & 
    2141                         &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  & 
    2142                         &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 
    2143  
    2144                        p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2145                   ENDIF 
    2146                   DO jj = njstr, njend, nn_facty 
    2147                      ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    2148                      ij   = ( jj - njstr ) * rfacty_r + 3 
    2149                      ijje = mje_crs(ij) 
    2150                      ijie = mie_crs(ii) 
    2151                      !   
    2152                      ze3crs = MAX( p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  & 
    2153                         &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  & 
    2154                         &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 
    2155  
    2156                      p_e3_max_crs(ii,ij,jk) = ze3crs 
    2157  
    2158                      ze3crs =  p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  & 
    2159                         &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  & 
    2160                         &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 
    2161  
    2162                        p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 
    2163  
     952            DO jk = 1, jpk 
     953               DO ji = nldi_crs, nlei_crs 
     954 
     955                  ijis = mis_crs(ji) 
     956                  ijie = mie_crs(ji) 
     957 
     958                  DO jj = nldj_crs, nlej_crs 
     959 
     960                     ijjs = mjs_crs(jj) 
     961                     ijje = mje_crs(jj) 
     962 
     963                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) ) 
     964 
     965                     ze3crs = SUM( p_e2(ijie,ijjs:ijje) * p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) ) 
     966                     IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj) 
    2164967                  ENDDO 
    2165968               ENDDO 
     
    2167970 
    2168971         CASE ('V') 
    2169          DO jk = 1 , jpk 
    2170                DO ji = nistr, niend, nn_factx 
    2171  
    2172                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2173                   IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2 
    2174  
    2175                      IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2176  
    2177                     jj = mje_crs(2) 
    2178  
    2179  
    2180                     ze3crs = MAX(  p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  & 
    2181                         &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  & 
    2182                         &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk)) 
    2183  
    2184                     p_e3_max_crs(ii,2,jk) = ze3crs 
    2185  
    2186                     ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  & 
    2187                         &     p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  & 
    2188                         &     p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) 
    2189  
    2190  
    2191                      p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2192                      ENDIF 
    2193                   ELSE 
    2194                      jj = mjs_crs(2) 
    2195  
    2196                      ze3crs = MAX( p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  & 
    2197                         &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  & 
    2198                         &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 
    2199  
    2200                      p_e3_max_crs(ii,2,jk) = ze3crs 
    2201  
    2202                      ze3crs =  p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  & 
    2203                         &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  & 
    2204                         &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 
    2205  
    2206                        p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2207                   ENDIF 
    2208  
    2209                   DO jj = njstr, njend, nn_facty 
    2210                      ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    2211                      ij   = ( jj - njstr ) * rfacty_r + 3 
    2212                      ijje = mje_crs(ij) 
    2213                      ijie = mie_crs(ii) 
    2214                      !   
    2215                      ze3crs = MAX( p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  & 
    2216                         &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  & 
    2217                         &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 
    2218  
    2219                      p_e3_max_crs(ii,ij,jk) = ze3crs 
    2220  
    2221                      ze3crs =  p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  & 
    2222                         &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  & 
    2223                         &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 
    2224  
    2225                        p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 
     972 
     973            DO jk = 1, jpk 
     974               DO ji = nldi_crs, nlei_crs 
     975 
     976                  ijis = mis_crs(ji) 
     977                  ijie = mie_crs(ji) 
     978 
     979                  DO jj = nldj_crs, nlej_crs 
     980 
     981                     ijjs = mjs_crs(jj) 
     982                     ijje = mje_crs(jj) 
     983 
     984                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) ) 
     985 
     986                     ze3crs = SUM( p_e1(ijis:ijie,ijje) * p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) ) 
     987                     IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj) 
    2226988 
    2227989                  ENDDO 
    2228990               ENDDO 
    2229991            ENDDO 
     992 
    2230993         CASE ('W') 
    2231994 
    2232             DO jk = 2 , jpk 
    2233                DO ji = nistr, niend, nn_factx 
    2234                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2235                IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2 
    2236  
    2237                  IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2238  
    2239                     jj = mje_crs(2) 
    2240  
    2241  
    2242                     ze3crs = MAX(  p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  & 
    2243                         &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  & 
    2244                         &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1)) 
    2245  
    2246                      p_e3_max_crs(ii,2,jk) = ze3crs 
    2247  
    2248                      ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk-1) +  & 
    2249                         &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk-1) +  & 
    2250                         &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk-1) 
    2251  
    2252  
    2253                        p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2254                   ENDIF 
    2255                ELSE 
    2256                   jj = mjs_crs(2) 
    2257  
    2258                   ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  & 
    2259                      &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  & 
    2260                      &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1),  & 
    2261                      &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1),  & 
    2262                      &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1),  & 
    2263                      &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1),  & 
    2264                      &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1),  & 
    2265                      &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1),  & 
    2266                      &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 
    2267  
    2268                   p_e3_max_crs(ii,2,jk) = ze3crs 
    2269                   ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk-1) +  & 
    2270                      &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk-1) +  & 
    2271                      &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk-1) +  & 
    2272                      &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk-1) +  & 
    2273                      &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) +  & 
    2274                      &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) +  & 
    2275                      &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk-1) +  & 
    2276                      &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) +  & 
    2277                      &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1) 
    2278  
    2279                   p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 
    2280                ENDIF 
    2281  
    2282  
    2283                   DO jj = njstr, njend, nn_facty 
    2284                      ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    2285                      ij   = ( jj - njstr ) * rfacty_r + 3 
    2286                      ijje = mje_crs(ij) 
    2287                      ijie = mie_crs(ii) 
    2288                      !   
    2289                      ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  & 
    2290                         &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  & 
    2291                         &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1),  & 
    2292                         &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1),  & 
    2293                         &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1),  & 
    2294                         &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1),  & 
    2295                         &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1),  & 
    2296                         &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1),  & 
    2297                         &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 
    2298  
    2299                      p_e3_max_crs(ii,ij,jk) = ze3crs 
    2300  
    2301                      ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk-1) +  & 
    2302                         &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk-1) +  & 
    2303                         &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk-1) +  & 
    2304                         &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk-1) +  & 
    2305                         &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) +  & 
    2306                         &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) +  & 
    2307                         &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk-1) +  & 
    2308                         &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) +  & 
    2309                         &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1) 
    2310  
    2311                        p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 
     995            DO jk = 1, jpk 
     996               DO ji = nldi_crs, nlei_crs 
     997 
     998                  ijis = mis_crs(ji) 
     999                  ijie = mie_crs(ji) 
     1000 
     1001                  DO jj = nldj_crs, nlej_crs 
     1002 
     1003                     ijjs = mjs_crs(jj) 
     1004                     ijje = mje_crs(jj) 
     1005 
     1006                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 
     1007 
     1008                     ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) ) 
     1009                     IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk) 
    23121010 
    23131011                  ENDDO 
     
    23151013            ENDDO 
    23161014 
    2317  
    2318             !first level 
    2319             DO ji = nistr, niend, nn_factx 
    2320                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2321                IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2 
    2322  
    2323                  IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2324  
    2325                     jj = mje_crs(2) 
    2326  
    2327                     ze3crs = MAX(  p_e3(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  & 
    2328                         &          p_e3(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  & 
    2329                         &          p_e3(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1)) 
    2330  
    2331                     p_e3_max_crs(ii,2,1) = ze3crs 
    2332  
    2333                     ze3crs =  p_e3(ji  ,jj  ,1) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,1) +  & 
    2334                         &      p_e3(ji+1,jj  ,1) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,1) +  & 
    2335                         &      p_e3(ji+2,jj  ,1) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,1) 
    2336  
    2337                     p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1) 
    2338                   ENDIF 
    2339                ELSE 
    2340                   jj = mjs_crs(2) 
    2341  
    2342                   ze3crs = MAX( p_e3(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  & 
    2343                      &          p_e3(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  & 
    2344                      &          p_e3(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1),  & 
    2345                      &          p_e3(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1),  & 
    2346                      &          p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1),  & 
    2347                      &          p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1),  & 
    2348                      &          p_e3(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1),  & 
    2349                      &          p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1),  & 
    2350                      &          p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 
    2351  
    2352                   p_e3_max_crs(ii,2,1) = ze3crs 
    2353                   ze3crs =  p_e3(ji  ,jj  ,1) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,1) +  & 
    2354                         &    p_e3(ji+1,jj  ,1) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,1) +  & 
    2355                         &    p_e3(ji+2,jj  ,1) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,1) +  & 
    2356                         &    p_e3(ji  ,jj+1,1) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,1) +  & 
    2357                         &    p_e3(ji+1,jj+1,1) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,1) +  & 
    2358                         &    p_e3(ji+2,jj+1,1) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,1) +  & 
    2359                         &    p_e3(ji  ,jj+2,1) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,1) +  & 
    2360                         &    p_e3(ji+1,jj+2,1) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,1) +  & 
    2361                         &    p_e3(ji+2,jj+2,1) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,1) 
    2362  
    2363                    p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1) 
    2364  
    2365                ENDIF 
    2366                DO jj = njstr, njend, nn_facty 
    2367                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
    2368                   ij   = ( jj - njstr ) * rfacty_r + 3 
    2369                   ijje = mje_crs(ij) 
    2370                   ijie = mie_crs(ii) 
    2371                   !   
    2372                   ze3crs = MAX( p_e3(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  & 
    2373                      &          p_e3(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  & 
    2374                      &          p_e3(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1),  & 
    2375                      &          p_e3(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1),  & 
    2376                      &          p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1),  & 
    2377                      &          p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1),  & 
    2378                      &          p_e3(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1),  & 
    2379                      &          p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1),  & 
    2380                      &          p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 
    2381  
    2382                   p_e3_max_crs(ii,ij,1) = ze3crs 
    2383  
    2384                    ze3crs =  p_e3(ji  ,jj  ,1) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,1) +  & 
    2385                         &    p_e3(ji+1,jj  ,1) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,1) +  & 
    2386                         &    p_e3(ji+2,jj  ,1) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,1) +  & 
    2387                         &    p_e3(ji  ,jj+1,1) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,1) +  & 
    2388                         &    p_e3(ji+1,jj+1,1) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,1) +  & 
    2389                         &    p_e3(ji+2,jj+1,1) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,1) +  & 
    2390                         &    p_e3(ji  ,jj+2,1) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,1) +  & 
    2391                         &    p_e3(ji+1,jj+2,1) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,1) +  & 
    2392                         &    p_e3(ji+2,jj+2,1) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,1) 
    2393  
    2394                        p_e3_crs(ii,ij,1) = ze3crs / p_sfc_crs(ii,ij,1) 
    2395  
    2396                ENDDO 
    2397             ENDDO 
    2398         !               
    2399        END SELECT 
    2400  
    2401          CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 
    2402          CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pval=1.0 ) 
    2403        !               
    2404        !CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zmask ) 
    2405        ! 
     1015      END SELECT 
     1016 
     1017      CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 
     1018      CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pval=1.0 ) 
     1019 
    24061020   END SUBROUTINE crs_dom_e3 
    24071021 
    2408    SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk,  p_e1, p_e2, p_e3 ) 
    2409  
     1022   SUBROUTINE crs_dom_sfc(p_mask, cd_type, p_surf_crs, p_surf_crs_msk,  p_e1, p_e2, p_e3 ) 
     1023      !!========================================================================================= 
     1024      !! 
     1025      !! 
     1026      !!========================================================================================= 
    24101027      !!  Arguments 
    24111028      CHARACTER(len=1),                         INTENT(in)           :: cd_type      ! grid type T, W ( U, V, F) 
     
    24181035      !! Local variables 
    24191036      INTEGER  :: ji, jj, jk                   ! dummy loop indices 
    2420       INTEGER  :: ii, ij, je_2 
    2421       INTEGER  :: iji,ijj 
     1037      INTEGER  :: ijis,ijie,ijjs,ijje 
    24221038      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk    
    24231039      !!----------------------------------------------------------------   
     
    24341050               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:)  
    24351051            ENDDO 
    2436             !zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1)  
    2437             !cbr DO jk = 2, jpk 
    2438             DO jk = 1, jpk 
    2439                !cbr zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1)  
    2440                zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)  
    2441             ENDDO 
    24421052 
    24431053         CASE ('V')      
     
    24451055               zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk)  
    24461056            ENDDO 
    2447             DO jk = 1, jpk 
    2448                zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)  
    2449             ENDDO 
    2450  
     1057  
    24511058         CASE ('U')      
    24521059            DO jk = 1, jpk 
    24531060               zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk)  
    24541061            ENDDO 
    2455             DO jk = 1, jpk 
    2456                zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)  
    2457             ENDDO 
    24581062 
    24591063         CASE DEFAULT 
     
    24611065               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:)  
    24621066            ENDDO 
     1067      END SELECT 
     1068 
     1069      DO jk = 1, jpk 
     1070         zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
     1071      ENDDO 
     1072 
     1073      SELECT CASE ( cd_type ) 
     1074 
     1075         CASE ('W') 
     1076 
    24631077            DO jk = 1, jpk 
    2464                zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)  
    2465             ENDDO 
     1078               DO jj = nldj_crs,nlej_crs 
     1079                  ijjs=mjs_crs(jj) 
     1080                  ijje=mje_crs(jj) 
     1081                  DO ji = nldi_crs,nlei_crs 
     1082                     ijis=mis_crs(ji) 
     1083                     ijie=mie_crs(ji) 
     1084                     p_surf_crs    (ji,jj,jk) =  SUM(zsurf   (ijis:ijie,ijjs:ijje,jk) ) 
     1085                     p_surf_crs_msk(ji,jj,jk) =  SUM(zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     1086                  ENDDO       
     1087               ENDDO 
     1088            ENDDO    
     1089 
     1090         CASE ('U') 
     1091 
     1092            DO jk = 1, jpk 
     1093               DO jj = nldj_crs,nlej_crs 
     1094                  ijjs=mjs_crs(jj) 
     1095                  ijje=mje_crs(jj) 
     1096                  DO ji = nldi_crs,nlei_crs 
     1097                     ijis=mis_crs(ji) 
     1098                     ijie=mie_crs(ji) 
     1099                     p_surf_crs    (ji,jj,jk) =  SUM(zsurf   (ijie,ijjs:ijje,jk) ) 
     1100                     p_surf_crs_msk(ji,jj,jk) =  SUM(zsurfmsk(ijie,ijjs:ijje,jk) ) 
     1101                  ENDDO 
     1102               ENDDO 
     1103            ENDDO 
     1104 
     1105         CASE ('V') 
     1106 
     1107            DO jk = 1, jpk 
     1108               DO jj = nldj_crs,nlej_crs 
     1109                  ijjs=mjs_crs(jj) 
     1110                  ijje=mje_crs(jj) 
     1111                  DO ji = nldi_crs,nlei_crs 
     1112                     ijis=mis_crs(ji) 
     1113                     ijie=mie_crs(ji) 
     1114                     p_surf_crs    (ji,jj,jk) =  SUM(zsurf   (ijis:ijie,ijje,jk) ) 
     1115                     p_surf_crs_msk(ji,jj,jk) =  SUM(zsurfmsk(ijis:ijie,ijje,jk) ) 
     1116                  ENDDO 
     1117               ENDDO 
     1118            ENDDO 
     1119 
    24661120      END SELECT 
    24671121 
    2468       !WRITE(narea+200,*)"TOTO",nldj_crs,mjs_crs(1), mje_crs(1),mjs_crs(2), mje_crs(2),mjs_crs(3), mje_crs(3),mjs_crs(4), mje_crs(4) ; CALL FLUSH(narea+200) 
    2469  
    2470       SELECT CASE ( cd_type ) 
    2471  
    2472       CASE ('W') 
    2473  
    2474       IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    2475          IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2476             je_2 = mje_crs(2) 
    2477             DO jk = 1, jpk 
    2478                DO ji = nistr, niend, nn_factx 
    2479                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2  
    2480                   !     
    2481                   p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) & 
    2482                     &                      + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk)  ! Why ????? 
    2483                   ! 
    2484                   p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk)  
    2485                   ! 
    2486                ENDDO 
    2487             ENDDO 
    2488          ENDIF 
    2489       ELSE 
    2490          je_2 = mjs_crs(2) 
    2491          DO jk = 1, jpk 
    2492             DO ji = nistr, niend, nn_factx 
    2493                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2  
    2494                !   
    2495                p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk)  & 
    2496                     &                   + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk)  & 
    2497                     &                   + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk)   
    2498  
    2499                p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2  ,jk) + zsurfmsk(ji+1,je_2  ,jk) + zsurfmsk(ji+2,je_2  ,jk)  & 
    2500                     &                   + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk)  & 
    2501                     &                   + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk)   
    2502                 ENDDO 
    2503             ENDDO 
    2504       ENDIF 
    2505           
    2506       DO jk = 1, jpk 
    2507          DO jj = njstr, njend, nn_facty 
    2508             DO ji = nistr, niend, nn_factx 
    2509                ii = ( ji - mis_crs(2) ) * rfactx_r + 2   
    2510                ij = ( jj - njstr ) * rfacty_r + 3 
    2511                ! 
    2512                p_surf_crs    (ii,ij,jk) =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk)  & 
    2513                     &                    + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk)  & 
    2514                     &                    + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk)   
    2515                p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji,jj  ,jk) + zsurfmsk(ji+1,jj  ,jk) + zsurfmsk(ji+2,jj  ,jk)  & 
    2516                     &                    + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk)  & 
    2517                     &                    + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk)   
    2518  
    2519             ENDDO       
    2520          ENDDO 
    2521       ENDDO    
    2522  
    2523       CASE ('U') 
    2524  
    2525      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    2526          IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2527             je_2 = mje_crs(2) 
    2528             DO jk = 1, jpk 
    2529                DO ji = nistr, niend, nn_factx 
    2530                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2531                   !     
    2532                   p_surf_crs    (ii,2,jk) =  zsurf(ji+2,je_2  ,jk) 
    2533                   ! 
    2534                   p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji+2,je_2,jk) 
    2535                   ! 
    2536                ENDDO 
    2537             ENDDO 
    2538          ENDIF 
    2539       ELSE 
    2540          je_2 = mjs_crs(2) 
    2541          DO jk = 1, jpk 
    2542             DO ji = nistr, niend, nn_factx 
    2543                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2544                !   
    2545                p_surf_crs    (ii,2,jk) =  zsurf(ji+2,je_2  ,jk)  & 
    2546                     &                   + zsurf(ji+2,je_2+1,jk)  & 
    2547                     &                   + zsurf(ji+2,je_2+2,jk) 
    2548  
    2549                p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji+2,je_2  ,jk)  & 
    2550                     &                   + zsurfmsk(ji+2,je_2+1,jk)  & 
    2551                     &                   + zsurfmsk(ji+2,je_2+2,jk) 
    2552                 ENDDO 
    2553             ENDDO 
    2554       ENDIF 
    2555  
    2556       DO jk = 1, jpk 
    2557          DO jj = njstr, njend, nn_facty 
    2558             DO ji = nistr, niend, nn_factx 
    2559                ii = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2560                ij = ( jj - njstr ) * rfacty_r + 3 
    2561                ! 
    2562                p_surf_crs    (ii,ij,jk) =  zsurf(ji+2,jj  ,jk)  & 
    2563                     &                    + zsurf(ji+2,jj+1,jk)  & 
    2564                     &                    + zsurf(ji+2,jj+2,jk) 
    2565                p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji+2,jj  ,jk)  & 
    2566                     &                    + zsurfmsk(ji+2,jj+1,jk)  & 
    2567                     &                    + zsurfmsk(ji+2,jj+2,jk) 
    2568             ENDDO 
    2569          ENDDO 
    2570       ENDDO 
    2571  
    2572       CASE ('V') 
    2573  
    2574       IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2 
    2575          IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 
    2576             je_2 = mje_crs(2) 
    2577             DO jk = 1, jpk 
    2578                DO ji = nistr, niend, nn_factx 
    2579                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2580                   !     
    2581                   p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) 
    2582                   ! 
    2583                   p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 
    2584                   ! 
    2585                ENDDO 
    2586             ENDDO 
    2587          ENDIF 
    2588       ELSE 
    2589          je_2 = mjs_crs(2) 
    2590          DO jk = 1, jpk 
    2591             DO ji = nistr, niend, nn_factx 
    2592                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2593                !   
    2594                p_surf_crs    (ii,2,jk) = zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 
    2595                p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) 
    2596             ENDDO 
    2597          ENDDO 
    2598       ENDIF 
    2599  
    2600       DO jk = 1, jpk 
    2601          DO jj = njstr, njend, nn_facty 
    2602             DO ji = nistr, niend, nn_factx 
    2603                ii = ( ji - mis_crs(2) ) * rfactx_r + 2 
    2604                ij = ( jj - njstr ) * rfacty_r + 3 
    2605                ! 
    2606                p_surf_crs    (ii,ij,jk) =  zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 
    2607                p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 
    2608                !iji=117 ; ijj=210 
    2609                !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 
    2610                !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 
    2611                !WRITE(narea+5000,*)"SFC V =======> " 
    2612                !WRITE(narea+5000,*)ii,ij,jk 
    2613                !WRITE(narea+5000,*)ji,jj 
    2614                !WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk),zsurfmsk(ji+1,jj+2,jk),zsurfmsk(ji+2,jj+2,jk) 
    2615                !WRITE(narea+5000,*)p_surf_crs    (ii,ij,jk),p_surf_crs_msk(ii,ij,jk) 
    2616                !ENDIF 
    2617             ENDDO 
    2618          ENDDO 
    2619       ENDDO 
    2620  
    2621      END SELECT 
    2622       !DO jk=1,jpk 
    2623       !DO ji=1,jpi_crs 
    2624       !DO jj=1,jpj_crs 
    2625       !   IF( p_surf_crs_msk(ji,jj,jk) .NE. p_surf_crs_msk(ji,jj,jk) )WRITE(narea+200,*)"SFC 4 ",ji,jj,jk,p_surf_crs_msk(ji,jj,jk)  ; call flush(narea+200) 
    2626       !ENDDO 
    2627       !ENDDO 
    2628       !ENDDO 
    2629       CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pval=1.0 ) 
    2630       CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 
     1122      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0 ) !cbr , pval=1.0 ) 
     1123      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0 ) !cbr , pval=1.0 ) 
    26311124 
    26321125      CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 
     
    26471140      INTEGER  :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn      ! dummy indices 
    26481141      INTEGER  :: ierr                                ! allocation error status 
    2649       INTEGER :: ii,ij,iproc,iprocno,iprocso,iimppt_crs 
     1142      INTEGER :: iproci,iprocj,iproc,iprocno,iprocso,iimppt_crs 
     1143      INTEGER :: ii_start,ii_end,ij_start,ij_end 
    26501144  
    26511145   
     
    26541148  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 2  ! the -2 removes j=1, j=jpj 
    26551149  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 3 
    2656       jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 
     1150      jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 2 
    26571151      jpiglo_crsm1 = jpiglo_crs - 1 
    26581152      jpjglo_crsm1 = jpjglo_crs - 1   
    26591153 
    26601154      jpi_crs = ( jpiglo_crs   - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci 
    2661       jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj    
    2662       !WRITE(narea+200,*)"jpj_crs noso = ", jpj_crs , noso         
    2663       IF( noso < 0 ) jpj_crs = jpj_crs + 1    ! add a local band on southern processors   ! celle qui est faite de zeros 
    2664       !WRITE(narea+200,*)"jpj_crs = ", jpj_crs 
     1155      jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj 
     1156!cbr?      IF( njmpp==1 )THEN 
     1157!         jpj_crs=jpj_crs+1 
     1158!      ENDIF 
     1159 
    26651160        
    26661161      jpi_crsm1   = jpi_crs - 1 
     
    26951190        ! mpp_ini2 
    26961191        !============================================================================================== 
    2697  
    2698         !cbr 
    2699         DO jn = 1, jpnij 
    2700            !WRITE(narea+200,*)"=====> jn",jn  ; call flush(narea+200) 
    2701  
    2702            !proc jn 
    2703            DO ji = 1 , jpni 
    2704               DO jj = 1 ,jpnj 
    2705                  IF( nfipproc(ji,jj)  == jn-1 )THEN 
    2706                     ii=ji 
    2707                     ij=jj 
    2708                  ENDIF 
    2709               ENDDO  
    2710            ENDDO  
    2711            iproc =  ii + jpni * ( ij-1 ) - 1 
    2712            ! mppini :   
    2713            !iprocso =  ii + jpni * ( ij-2 ) - 1  
    2714            ! mppini2:           
    2715            IF( ij .GT. 1 )THEN ; iprocso =  nfipproc(ii,ij-1) 
    2716            ELSE                ; iprocso =  -1 
     1192        DO ji = 1 , jpni 
     1193           DO jj = 1 ,jpnj 
     1194              IF( nfipproc(ji,jj)  == narea-1 )THEN 
     1195                 iproci=ji 
     1196                 iprocj=jj 
     1197              ENDIF 
     1198           ENDDO 
     1199        ENDDO 
     1200 
     1201        !WRITE(narea+8000-1,*)"nfipproc(ji,jj),narea :",nfipproc(iproci,iprocj),narea 
     1202        !WRITE(narea+8000-1,*)"proc i,j ",iproci,iprocj 
     1203        !WRITE(narea+8000-1,*)"nowe noea",nowe,noea 
     1204        !WRITE(narea+8000-1,*)"noso nono",noso,nono 
     1205        !WRITE(narea+8000-1,*)"nbondi nbondj ",nbondi,nbondj 
     1206        !WRITE(narea+8000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo 
     1207        !WRITE(narea+8000-1,*)"jpi jpj ",jpi,jpj 
     1208        !WRITE(narea+8000-1,*)"nbondi nbondj",nbondi,nbondj 
     1209        !WRITE(narea+8000-1,*)"nimpp njmpp ",nimpp,njmpp 
     1210        !WRITE(narea+8000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi        ,nlei         ,nlci 
     1211        !WRITE(narea+8000-1,*)"glo jpi nldi,nlei      ",jpi, nldi+nimpp-1,nlei+nimpp-1 
     1212        !WRITE(narea+8000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj        ,nlej         ,nlcj 
     1213        !WRITE(narea+8000-1,*)"glo jpj nldj,nlej      ",jpj, nldj+njmpp-1,nlej+njmpp-1 
     1214        !WRITE(narea+8000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs 
     1215        !WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs 
     1216        !WRITE(narea+8000-1,*)"jpni  jpnj jpnij ",jpni,jpnj,jpnij 
     1217        !WRITE(narea+8000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj) 
     1218        !========================================================================== 
     1219        ! dim along I 
     1220        !========================================================================== 
     1221        SELECT CASE ( nperio ) 
     1222        CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold 
     1223 
     1224           DO ji=1,jpiglo_crs 
     1225              ijis=nn_factx*(ji-1)-2 
     1226              ijie=nn_factx*(ji-1) 
     1227              mis2_crs(ji)=ijis 
     1228              mie2_crs(ji)=ijie 
     1229           ENDDO 
     1230 
     1231           ji=1 
     1232           DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 )  
     1233              ji=ji+1 
     1234              IF( ji==jpiglo_crs )EXIT 
     1235           END DO 
     1236           ijis=ji 
     1237 
     1238           !mjs2_crs(ijis)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur 
     1239           !ijis          =indice global ds la grille    crs de la premire maille qui est ds le domaine intérieur 
     1240           !ii_start      =indice local de mjs2_crs(jj) 
     1241           ii_start = mis2_crs(ijis)-nimpp+1 
     1242           nimpp_crs = ijis-1 
     1243 
     1244           nldi_crs = 2 
     1245           IF( nowe == -1 )THEN 
     1246 
     1247               mie2_crs(ijis-1) = mis2_crs(ijis)-1 
     1248               
     1249               SELECT CASE(ii_start) 
     1250                  CASE(1) 
     1251                     nldi_crs=2 
     1252                     mie2_crs(ijis-1) = -1 
     1253                     mis2_crs(ijis-1) = -1 
     1254                  CASE(2) 
     1255!CBR?                     nldi_crs=1 
     1256                     nldi_crs=2 
     1257                     mis2_crs(ijis-1) = mie2_crs(ijis-1) 
     1258                  CASE(3) 
     1259!CBR?                     nldi_crs=1 
     1260                     nldi_crs=2 
     1261                     mis2_crs(ijis-1) = mie2_crs(ijis-1) -1 
     1262                  CASE DEFAULT 
     1263                     WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start 
     1264               END SELECT 
     1265 
     1266           ENDIF 
     1267 
     1268           IF( nimpp==1 )nimpp_crs=1 
     1269 
     1270           !---------------------------------------- 
     1271           ji=jpiglo_crs 
     1272           DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. jpi ) 
     1273              ji=ji-1 
     1274              IF( ji==1 )EXIT 
     1275           END DO 
     1276           ijie=ji 
     1277           nlei_crs=ijie-nimpp_crs+1 
     1278           nlci_crs=nlei_crs+jpreci 
     1279 
     1280           !---------------------------------------- 
     1281           DO ji = 1, jpi_crs 
     1282              mig_crs(ji) = ji + nimpp_crs - 1 
     1283           ENDDO 
     1284           DO ji = 1, jpiglo_crs 
     1285              mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 
     1286              mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) ) 
     1287           ENDDO 
     1288 
     1289           !---------------------------------------- 
     1290           DO ji = 1, nlei_crs 
     1291              mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 
     1292              mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 
     1293              nfactx(ji)  = mie_crs(ji)-mie_crs(ji)+1 
     1294           ENDDO 
     1295 
     1296           IF( iproci == jpni )THEN 
     1297              nlei_crs=nlci_crs 
     1298              mis_crs(nlei_crs)=mis_crs(nlei_crs-1) 
     1299              mie_crs(nlei_crs)=mie_crs(nlei_crs-1) 
     1300           ENDIF 
     1301 
     1302           !---------------------------------------- 
     1303 
     1304        CASE DEFAULT 
     1305           WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported' 
     1306        END SELECT 
     1307 
     1308        !========================================================================== 
     1309        ! dim along J 
     1310        !========================================================================== 
     1311        SELECT CASE ( nperio ) 
     1312        CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold 
     1313 
     1314           DO jj=1,jpjglo_crs 
     1315              ijjs=nn_facty*(jj)-5 
     1316              ijje=nn_facty*(jj)-3 
     1317              mjs2_crs(jj)=ijjs 
     1318              mje2_crs(jj)=ijje 
     1319           ENDDO 
     1320 
     1321           jj=1 
     1322           DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 ) 
     1323              jj=jj+1 
     1324              IF( jj==jpjglo_crs )EXIT 
     1325           END DO 
     1326           ijjs=jj 
     1327 
     1328           !mjs2_crs(jj)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur 
     1329           !ijjs        =indice global ds la grille    crs de la premire maille qui est ds le domaine intérieur 
     1330           !ij_start    =indice local de mjs2_crs(jj) 
     1331           ij_start = mjs2_crs(ijjs)-njmpp+1 
     1332           njmpp_crs = ijjs-1 
     1333 
     1334           nldj_crs = 2 
     1335           IF( noso == -1 )THEN 
     1336 
     1337               mje2_crs(ijjs-1) = mjs2_crs(ijjs)-1 
     1338 
     1339               SELECT CASE(ij_start) 
     1340                  CASE(1) 
     1341                     nldj_crs=2 
     1342                     mje2_crs(ijjs-1) = -1 
     1343                     mjs2_crs(ijjs-1) = -1 
     1344                  CASE(2) 
     1345!CBR?                     nldj_crs=1 
     1346                     nldj_crs=2 
     1347                     mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) 
     1348                  CASE(3) 
     1349!CBR?                     nldj_crs=1 
     1350                     nldj_crs=2 
     1351                     mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) -1 
     1352                  CASE DEFAULT 
     1353                     WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start 
     1354               END SELECT 
     1355 
     1356           ENDIF 
     1357           IF( njmpp==1 )njmpp_crs=1 
     1358 
     1359 
     1360           !---------------------------------------- 
     1361           jj=jpjglo_crs 
     1362           DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj ) 
     1363              jj=jj-1 
     1364              IF( jj==1 )EXIT 
     1365           END DO 
     1366           ijje=jj 
     1367 
     1368           nlej_crs=ijje-njmpp_crs+1 
     1369 
     1370           !---------------------------------------- 
     1371           nlcj_crs=nlej_crs+jprecj 
     1372           IF( iprocj == jpnj )THEN 
     1373              nlej_crs=jpj_crs ! cbr -1 ???????????????????? 
     1374              nlcj_crs=nlej_crs 
    27171375           ENDIF 
    27181376  
    2719            !WRITE(narea+200,*)ii,ij  ; call flush(narea+200) 
    2720            !WRITE(narea+200,*)"iproc iprocso ",iproc,iprocso 
    2721            !WRITE(narea+200,*)"jpiglo jpjglo ",jpiglo,jpjglo 
    2722            !WRITE(narea+200,*)"ibonit(jn) ibonjt(jn) ",ibonit(jn),ibonjt(jn) ; call flush(narea+200) 
    2723            !WRITE(narea+200,*)"nimppt(jn) njmppt(jn) ",nimppt(jn),njmppt(jn) ; call flush(narea+200) 
    2724            !WRITE(narea+200,*)"loc jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn),nlejt(jn),nlcjt(jn) ; call flush(narea+200) 
    2725            !WRITE(narea+200,*)"glo jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn)+njmppt(jn)-1,nlejt(jn)+njmppt(jn)-1,nlcjt(jn) ; call flush(narea+200) 
    2726  
    2727            !dimension selon j 
    2728            !------------------- 
    2729            IF( ibonjt(jn) .NE. 1 )THEN !on a besoin de savoir si jn est au nord 
    2730               !iprocno=nfipproc(ii,ij+1)  
    2731                  !iprocno=iprocno+1 
    2732                  !WRITE(narea+200,*)"ii,ij+1 ",ii,ij+1; call flush(narea+200) 
    2733                  !WRITE(narea+200,*)"njmppt  jn njmpptno(jn) ",njmppt(jn),njmpptno(jn); call flush(narea+200) 
    2734                  !WRITE(narea+200,*)"jpjglo",jpjglo ; call flush(narea+200) 
    2735  
    2736                  !WRITE(narea+200,*)REAL( ( jpjglo - (njmppt  (jn) - 1) ) / nn_facty, wp ),REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ); call flush(narea+200) 
    2737                  !WRITE(narea+200,*)AINT( REAL( ( jpjglo - (njmppt  (jn) - 1) ) / nn_facty, wp ) ),AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) ); call flush(narea+200) 
    2738  
    2739                  nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt  (jn) - 1) ) / nn_facty, wp ) ) & 
    2740                       &        - AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) ) 
    2741            ELSE ! ibonjt=1 : au nord 
    2742               nlejt_crs(jn) = AINT( REAL(  nlejt(jn) / nn_facty, wp ) ) + 1 
     1377           !---------------------------------------- 
     1378           DO jj = 1, jpj_crs 
     1379              mjg_crs(jj) = jj + njmpp_crs - 1 
     1380           ENDDO 
     1381           DO jj = 1, jpjglo_crs 
     1382              mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 
     1383              mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) ) 
     1384           ENDDO 
     1385 
     1386           !---------------------------------------- 
     1387           DO jj = 1, nlej_crs 
     1388              mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 
     1389              mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 
     1390              nfacty(jj)   = mje_crs(jj)-mje_crs(jj)+1 
     1391           ENDDO 
     1392 
     1393           IF( iprocj == jpnj )THEN 
     1394              mjs_crs(nlej_crs)=mjs_crs(nlej_crs-1) 
     1395              mje_crs(nlej_crs)=mje_crs(nlej_crs-1) 
    27431396           ENDIF 
    2744            !==> nbondj = -1 au sud, 0 au milieu, 1 au nord, 2 si jpnj=1 
    2745            !WRITE(narea+200,*)"nlejt_crs(jn) ",nlejt_crs(jn) ; call flush(narea+200) 
    2746            !!!noso== nbre de proc sud du proc sur lequel on tourne !!!! ; dangeureux car on est ds une boucle sur jn 
    2747            IF( iprocso < 0 .AND. ibonjt(jn) == -1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 
    2748            SELECT CASE( ibonjt(jn) ) 
    2749               CASE ( -1 ) 
    2750                 !WRITE(narea+200,*)"MOD( jpjglo - njmppt(jn), nn_facty)",MOD( jpjglo - njmppt(jn), nn_facty) ; call flush(narea+200) 
    2751                 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nlejt_crs(jn) = nlejt_crs(jn) + 1  ! au cas où il reste des lignes en bas 
    2752                 IF( nldjt(jn) == 1 )  nlejt_crs(jn) = nlejt_crs(jn) + 1 
    2753                 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 
    2754                 nldjt_crs(jn) = nldjt(jn) 
    2755                 !???nlejt_crs(jn) = nlejt_crs(jn) + 1 ! 2 !cbr   
    2756               CASE ( 0 ) 
    2757  
    2758                 nldjt_crs(jn) = nldjt(jn) 
    2759                 IF( nldjt(jn) == 1 )  nlejt_crs(jn) = nlejt_crs(jn) + 1 
    2760                 nlejt_crs(jn) = nlejt_crs(jn) + jprecj 
    2761                 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 
    2762  
    2763               CASE ( 1, 2 ) 
    2764     
    2765                 nlejt_crs(jn) = nlejt_crs(jn) + jprecj 
    2766                 nlcjt_crs(jn) = nlejt_crs(jn) 
    2767                 nldjt_crs(jn) = nldjt(jn) 
    2768               CASE DEFAULT 
    2769                  STOP 
    2770            END SELECT 
    2771            !WRITE(narea+200,*)"jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) " ; call flush(narea+200) 
    2772            !WRITE(narea+200,*) jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200) 
    2773            IF( nlcjt_crs(jn) > jpj_crs )THEN 
    2774               jpj_crs = jpj_crs + 1 
    2775               nlejt_crs(jn) = nlejt_crs(jn) + 1 
    2776            ENDIF 
    2777            !cbr pas bon !!!! 
    2778            !on augmente la taille des domaines alors que les tblx st deja alloués 
    2779            !du coup on alloue les tblx apres: 
    2780            IF(nldjt_crs(jn) == 1 ) THEN 
    2781               njmppt_crs(jn) = 1 
    2782            ELSE 
    2783               njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) 
    2784            ENDIF 
    2785            !WRITE(narea+200,*)"tutu loc ",jn,jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200) 
    2786            !WRITE(narea+200,*)"tutu glo ",jn,jpj_crs, nldjt_crs(jn)+njmppt_crs(jn)-1,nlejt_crs(jn)+njmppt_crs(jn)-1,nlcjt_crs(jn)+njmppt_crs(jn)-1 ; call flush(narea+200) 
    2787  
    2788  
    2789            !dimensions selon i 
    2790            !------------------- 
    2791            !IF( jn == 1 ) THEN 
    2792            !IF( ibonit(jn)==-1 )THEN !on a besoin de savoir si jn est un proc west 
    2793            IF( ii==1 )THEN !on a besoin de savoir si jn est un proc west 
    2794               nleit_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + nlcit(jn  ) )  / nn_factx, wp) ) 
    2795            ELSE 
    2796               !WRITE(narea+200,*)"njmppt  jn njmpptea(jn) ",nimppt(jn),nimpptea(jn); call flush(narea+200) 
    2797               !WRITE(narea+200,*)"nlcit  (jn) nlcitea(jn) ) ",nlcit  (jn),nlcitea(jn); call flush(narea+200) 
    2798               nleit_crs(jn) = AINT( REAL( ( nimppt  (jn) - 1 + nlcit  (jn) )  / nn_factx, wp) ) & 
    2799                  &          - AINT( REAL( ( nimpptea(jn) - 1 + nlcitea(jn) )  / nn_factx, wp) ) 
    2800            ENDIF 
    2801            !WRITE(narea+200,*)"nleji_crs(jn),noso ",nleit_crs(jn); call flush(narea+200) 
    2802  
    2803  
    2804            SELECT CASE( ibonit(jn) ) 
    2805               CASE ( -1 ) 
    2806                  nleit_crs(jn) = nleit_crs(jn) + jpreci 
    2807                  nlcit_crs(jn) = nleit_crs(jn) + jpreci 
    2808                  nldit_crs(jn) = nldit(jn) 
    2809  
    2810               CASE ( 0 ) 
    2811                  nleit_crs(jn) = nleit_crs(jn) + jpreci 
    2812                  nlcit_crs(jn) = nleit_crs(jn) + jpreci 
    2813                  nldit_crs(jn) = nldit(jn) 
    2814  
    2815               CASE ( 1, 2 ) 
    2816                  IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nleit_crs(jn) = nleit_crs(jn) + 1 
    2817                  nleit_crs(jn) = nleit_crs(jn) + jpreci 
    2818                  nlcit_crs(jn) = nleit_crs(jn) 
    2819                  nldit_crs(jn) = nldit(jn) 
    2820  
    2821               CASE DEFAULT 
    2822                  STOP 
    2823            END SELECT 
    2824            !WRITE(narea+200,*)"jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ",jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200) 
    2825            nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 
    2826  
    2827            !WRITE(narea+200,*)"tutu loc ",jn,jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200) 
    2828            !WRITE(narea+200,*)"tutu glo ",jn,jpi_crs, nldit_crs(jn)+nimppt_crs(jn)-1,nleit_crs(jn)+nimppt_crs(jn)-1,nlcit_crs(jn)+nimppt_crs(jn)-1 ; call flush(narea+200) 
    2829  
    2830            nfiimpp_crs(ii,ij) = nimppt_crs(jn) 
    2831            !WRITE(narea+200,*)"tutu nimppt_crs(jn) ",ii,ij,nimppt_crs(jn) ; call flush(narea+200) 
    2832            
    2833         ENDDO 
    2834  
    2835         DO ji = 1 , jpni 
    2836            DO jj = 1 ,jpnj 
     1397 
     1398           !---------------------------------------- 
     1399 
     1400        CASE DEFAULT 
     1401           WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported' 
     1402        END SELECT 
     1403 
     1404        !========================================================================== 
     1405        IF( nlci_crs .GT. jpi_crs .OR. nlei_crs .GT. jpi_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlei_crs,nlci_crs,jpi_crs; CALL FLUSH(narea+8000-1) 
     1406        IF( nlcj_crs .GT. jpj_crs .OR. nlej_crs .GT. jpj_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlej_crs,nlcj_crs,jpj_crs; CALL FLUSH(narea+8000-1) 
     1407        !========================================================================== 
     1408 
     1409        nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0 
     1410        nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0 
     1411 
     1412        CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs)  
     1413        CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs)  
     1414        CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs)  
     1415        CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs)  
     1416 
     1417        DO jj = 1 ,jpnj 
     1418           DO ji = 1 , jpni 
    28371419              jn=nfipproc(ji,jj)+1 
    2838               iimppt_crs = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1 
    2839               nfiimpp_crs(ji,jj) = iimppt_crs 
    2840               IF( jn .GE. 1 )nimppt_crs(jn) = iimppt_crs 
    2841               !PRINT*," nfiimpp_crs(ji,jj) ",ji,jj,jn,nfiimpp(ji,jj),nfiimpp_crs(ji,jj) 
     1420              IF( jn .GE. 1 )THEN 
     1421                 nfiimpp_crs(ji,jj)=nimppt_crs(jn) 
     1422              ELSE 
     1423                 nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1 
     1424              ENDIF 
    28421425           ENDDO 
    28431426        ENDDO 
    2844  
    2845         nlej_crs  = nlejt_crs(nproc + 1) 
    2846         nlcj_crs  = nlcjt_crs(nproc + 1) 
    2847         nldj_crs  = nldjt_crs(nproc + 1) 
    2848         njmpp_crs = njmppt_crs(nproc + 1) 
    2849  
    2850         nlei_crs  = nleit_crs(nproc + 1) 
    2851         nlci_crs  = nlcit_crs(nproc + 1) 
    2852         nldi_crs  = nldit_crs(nproc + 1) 
    2853         nimpp_crs = nimppt_crs(nproc + 1) 
    2854  
     1427  
    28551428        !nogather=T 
    28561429        nfsloop_crs = 1 
     
    28671440        END DO 
    28681441 
     1442        !WRITE(narea+8000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs            ,nlei_crs             ,nlci_crs 
     1443        !WRITE(narea+8000-1,*)"glo crs jpi nldi,nlei      ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 
     1444        !WRITE(narea+8000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs            ,nlej_crs             ,nlcj_crs 
     1445        !WRITE(narea+8000-1,*)"glo crs jpj nldj,nlej      ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 
    28691446        !============================================================================================== 
    2870          !write(narea+200,*)"jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1" ; call flush(narea+200) 
    2871          !write(narea+200,*)jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 ; call flush(narea+200) 
    2872          !write(narea+200,*)"jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1" ; call flush(narea+200) 
    2873          !write(narea+200,*)jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 ; call flush(narea+200) 
    2874          !write(narea+200,*)"nfsloop_crs nfeloop_crs ",nfsloop_crs,nfeloop_crs ; call flush(narea+200) 
    2875  
    2876          ! No coarsening with zoom 
    28771447         IF( jpizoom /= 1 .OR. jpjzoom /= 1)    STOP  
    28781448 
    2879          !cbr 
    2880          ierr = crs_dom_alloc1()  
    2881  
    2882          DO ji = 1, jpi_crs 
    2883             mig_crs(ji) = ji + nimpp_crs - 1 
    2884             !WRITE(narea+200,*)"fifi ",ji,mig_crs(ji)  ; call flush(narea+200) 
    2885          ENDDO 
    2886          DO jj = 1, jpj_crs 
    2887             mjg_crs(jj) = jj + njmpp_crs - 1! 
    2888             !WRITE(narea+200,*)"fufu ",jj,mjg_crs(jj)  ; call flush(narea+200) 
    2889          ENDDO 
    2890         
    2891          DO ji = 1, jpiglo_crs 
    2892             mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 
    2893             mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) ) 
    2894             !WRITE(narea+200,*)"mi ",ji,mi0_crs(ji),mi1_crs(ji)  ; call flush(narea+200) 
    2895          ENDDO 
    2896           
    2897          DO jj = 1, jpjglo_crs 
    2898             mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 
    2899             mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) ) 
    2900             !WRITE(narea+200,*)"mj ",jj, mj0_crs(jj),mj1_crs(jj) ; call flush(narea+200) 
    2901          ENDDO 
    2902  
    2903       ENDIF 
    2904        
    29051449      !                         Save the parent grid information 
    29061450      jpi_full    = jpi 
     
    29871531      rfactxy = nn_factx * nn_facty 
    29881532       
    2989       ! 2.b. Set up bins for coarse grid, horizontal only. 
    2990       ierr = crs_dom_alloc2() 
    2991       
    2992       mis2_crs(:) = 0      ;      mie2_crs(:) = 0 
    2993       mjs2_crs(:) = 0      ;      mje2_crs(:) = 0 
    2994  
    2995        
    2996       SELECT CASE ( nn_binref ) 
    2997  
    2998       CASE ( 0 )  
    2999  
    3000          SELECT CASE ( nperio ) 
    3001       
    3002   
    3003         CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold 
    3004          
    3005             DO ji = 2, jpiglo_crsm1 
    3006                ijie = ( ji * nn_factx ) - nn_factx   !cc 
    3007                ijis = ijie - nn_factx + 1 
    3008                mis2_crs(ji) = ijis 
    3009                mie2_crs(ji) = ijie 
    3010             ENDDO 
    3011             IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2   
    3012  
    3013             ! Handle first the northernmost bin 
    3014             IF ( nn_facty == 2 ) THEN   ;    ijjgloT = jpjglo - 1  
    3015             ELSE                        ;    ijjgloT = jpjglo 
    3016             ENDIF 
    3017  
    3018             DO jj = 2, jpjglo_crs 
    3019                 ijje = ijjgloT - nn_facty * ( jj - 3 ) 
    3020                 ijjs = ijje - nn_facty + 1                    
    3021                 mjs2_crs(jpjglo_crs-jj+2) = ijjs 
    3022                 mje2_crs(jpjglo_crs-jj+2) = ijje 
    3023                !WRITE(narea+200,*)"jpjglo_crs-jj+2,ijje,ijjs ",jpjglo_crs-jj+2,ijjs,ijje ; call flush(narea+200) 
    3024             ENDDO 
    3025  
    3026          CASE ( 2 )  
    3027             WRITE(numout,*)  'crs_init, jperio=2 not supported'  
    3028          
    3029          CASE ( 5, 6 )    ! F-pivot at North Fold 
    3030  
    3031             DO ji = 2, jpiglo_crsm1 
    3032                ijie = ( ji * nn_factx ) - nn_factx  
    3033                ijis = ijie - nn_factx + 1 
    3034                mis2_crs(ji) = ijis 
    3035                mie2_crs(ji) = ijie 
    3036             ENDDO 
    3037             IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1)  = jpiglo - 2  
    3038  
    3039             ! Treat the northernmost bin separately. 
    3040             jj = 2 
    3041             ijje = jpj - nn_facty * ( jj - 2 ) 
    3042             IF ( nn_facty == 3 ) THEN   ;  ijjs = ijje - 1  
    3043             ELSE                        ;  ijjs = ijje - nn_facty + 1 
    3044             ENDIF 
    3045             mjs2_crs(jpj_crs-jj+1) = ijjs 
    3046             mje2_crs(jpj_crs-jj+1) = ijje 
    3047  
    3048             ! Now bin the rest, any remainder at the south is lumped in the southern bin 
    3049             DO jj = 3, jpjglo_crsm1 
    3050                 ijje = jpjglo - nn_facty * ( jj - 2 ) 
    3051                 ijjs = ijje - nn_facty + 1                   
    3052                 IF ( ijjs <= nn_facty )  ijjs = 2 
    3053                 WRITE(narea+200,*)"fufu",jj,ijjs,ijje ; call flush(narea+200) 
    3054                 mjs2_crs(jpj_crs-jj+1)   = ijjs 
    3055                 mje2_crs(jpj_crs-jj+1)   = ijje 
    3056             ENDDO 
    3057  
    3058          CASE DEFAULT 
    3059             WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported'  
    3060   
    3061          END SELECT 
    3062  
    3063       CASE (1 ) 
    3064          WRITE(numout,*) 'crs_init.  Equator-centered bins option not yet available'  
    3065  
    3066       END SELECT 
    3067  
    3068      ! Pad the boundaries, do not know if it is necessary 
    3069       mis2_crs(2) = 1             ;  mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1    
    3070       mie2_crs(2) = nn_factx      ;  mie2_crs(jpiglo_crs) = jpiglo                          
    3071       ! 
    3072       mjs2_crs(1) = 1 
    3073       mje2_crs(1) = 1 
    3074       ! 
    3075       mje2_crs(2) = mjs2_crs(3)-1 ;  mje2_crs(jpjglo_crs) = jpjglo 
    3076       mjs2_crs(2) = 1             ;  mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1  
    3077   
    3078       IF( .NOT. lk_mpp ) THEN      
    3079         mis_crs(:) = mis2_crs(:)  
    3080         mie_crs(:) = mie2_crs(:) 
    3081         mjs_crs(:) = mjs2_crs(:)  
    3082         mje_crs(:) = mje2_crs(:)  
    3083       ELSE 
    3084        !write(narea+200,*)"njmpp ",njmpp 
    3085         DO jj = 1, nlej_crs 
    3086            !write(narea+200,*)jj,"mjs2_crs mje2_crs ",mjg_crs(jj),mjs2_crs(mjg_crs(jj)),mje2_crs(mjg_crs(jj)) ; call flush(narea+200) 
    3087            mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 
    3088            mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 
    3089            !write(narea+200,*)"mjs_crs mje_crs ",mjs_crs(jj),mje_crs(jj) ; call flush(narea+200) 
    3090         ENDDO 
    3091         !write(narea+200,*)"nimpp ",nimpp 
    3092         DO ji = 1, nlei_crs 
    3093            !write(narea+200,*)ji,"mis2_crs mie2_crs ",mig_crs(ji),mis2_crs(mig_crs(ji)),mie2_crs(mig_crs(ji)) ; call flush(narea+200) 
    3094            mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 
    3095            mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 
    3096            !write(narea+200,*)"mis_crs mie_crs ",mis_crs(jj),mie_crs(jj) ; call flush(narea+200) 
    3097         ENDDO 
    30981533      ENDIF 
    30991534      ! 
    3100       !IF( nlcj_crs -1 .GT. nlej_crs )WRITE(narea+200,*)"tutututu",nlcj_crs,nlej_crs ; call flush(narea+200) 
    31011535      nistr = mis_crs(2)  ;   niend = mis_crs(nlci_crs - 1) 
    31021536      njstr = mjs_crs(3)  ;   njend = mjs_crs(nlcj_crs - 1) 
     1537      ! 
    31031538      ! 
    31041539   END SUBROUTINE crs_dom_def 
  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90

    r5602 r6772  
    3333   PUBLIC crs_dom_wri        ! routine called by crsini.F90 
    3434 
    35    !! $Id$ 
    3635CONTAINS 
    3736 
     
    6564      CHARACTER(len=21) ::   clnam4   ! filename (vertical   mesh informations) 
    6665      INTEGER           ::   ji, jj, jk   ! dummy loop indices 
     66      INTEGER           ::   iji,ijj 
    6767      !                                   !  workspaces 
    6868      REAL(wp), POINTER, DIMENSION(:,:  ) :: zprt, zprw  
     
    122122      !======================================================== 
    123123      !                                                         ! masks (inum2)  
     124 
    124125      CALL iom_rstput( 0, 0, inum2, 'tmask', tmask_crs, ktype = jp_i1 )     !    ! land-sea mask 
    125126      CALL iom_rstput( 0, 0, inum2, 'umask', umask_crs, ktype = jp_i1 ) 
     
    202203             
    203204         IF ( nn_msh_crs <= 6 ) THEN 
    204             CALL iom_rstput( 0, 0, inum4, 'e3t', e3t_crs )       
    205             CALL iom_rstput( 0, 0, inum4, 'e3w', e3w_crs )       
    206             CALL iom_rstput( 0, 0, inum4, 'e3u', e3u_crs )       
    207             CALL iom_rstput( 0, 0, inum4, 'e3v', e3v_crs )       
    208             CALL iom_rstput( 0, 0, inum4, 'e3t_max_crs', e3t_max_crs )       
    209             CALL iom_rstput( 0, 0, inum4, 'e3w_max_crs', e3w_max_crs )       
     205            CALL iom_rstput( 0, 0, inum4, 'e3t', e3t_0_crs )       
     206            CALL iom_rstput( 0, 0, inum4, 'e3w', e3w_0_crs )       
     207            CALL iom_rstput( 0, 0, inum4, 'e3u', e3u_0_crs )       
     208            CALL iom_rstput( 0, 0, inum4, 'e3v', e3v_0_crs )       
     209            CALL iom_rstput( 0, 0, inum4, 'e3t_max_crs', e3t_max_0_crs )       
     210            CALL iom_rstput( 0, 0, inum4, 'e3w_max_crs', e3w_max_0_crs )       
    210211         ELSE 
    211212            DO jj = 1,jpj_crs    
    212213               DO ji = 1,jpi_crs 
    213                   ze3tp(ji,jj) = e3t_crs(ji,jj,mbkt_crs(ji,jj)) * tmask_crs(ji,jj,1) 
    214                   ze3wp(ji,jj) = e3w_crs(ji,jj,mbkt_crs(ji,jj)) * tmask_crs(ji,jj,1) 
     214                  ze3tp(ji,jj) = e3t_0_crs(ji,jj,mbkt_crs(ji,jj)) * tmask_crs(ji,jj,1) 
     215                  ze3wp(ji,jj) = e3w_0_crs(ji,jj,mbkt_crs(ji,jj)) * tmask_crs(ji,jj,1) 
    215216               END DO 
    216217            END DO 
     
    224225 
    225226         IF ( nn_msh_crs <= 3 ) THEN 
    226             CALL iom_rstput( 0, 0, inum4, 'gdept', gdept_crs, ktype = jp_r4 )  
     227            CALL iom_rstput( 0, 0, inum4, 'gdept', gdept_0_crs, ktype = jp_r4 )  
    227228            DO jk = 1,jpk    
    228229               DO jj = 1, jpj_crsm1    
    229230                  DO ji = 1, jpi_crsm1  ! jes what to do for fs_jpim1??vector opt. 
    230                      zdepu(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji+1,jj  ,jk) ) * umask_crs(ji,jj,jk) 
    231                      zdepv(ji,jj,jk) = MIN( gdept_crs(ji,jj,jk) , gdept_crs(ji  ,jj+1,jk) ) * vmask_crs(ji,jj,jk) 
     231                     zdepu(ji,jj,jk) = MIN( gdept_0_crs(ji,jj,jk) , gdept_0_crs(ji+1,jj  ,jk) ) * umask_crs(ji,jj,jk) 
     232                     zdepv(ji,jj,jk) = MIN( gdept_0_crs(ji,jj,jk) , gdept_0_crs(ji  ,jj+1,jk) ) * vmask_crs(ji,jj,jk) 
    232233                  END DO    
    233234               END DO    
     
    237238            CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r4 ) 
    238239            CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r4 ) 
    239             CALL iom_rstput( 0, 0, inum4, 'gdepw', gdepw_crs, ktype = jp_r4 ) 
     240            CALL iom_rstput( 0, 0, inum4, 'gdepw', gdepw_0_crs, ktype = jp_r4 ) 
    240241         ELSE 
    241242            DO jj = 1,jpj_crs    
  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90

    r6101 r6772  
    2424   USE crs 
    2525   USE crsdom 
     26   USE domvvl 
     27   USE domvvl_crs 
    2628   USE crslbclnk 
    2729   USE iom 
     
    3234   USE zdftke_crs 
    3335 
    34 !   USE ieee_arithmetic 
     36   USE ieee_arithmetic 
    3537 
    3638   IMPLICIT NONE 
     
    7779      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: avte_crs 
    7880      REAL(wp)       :: z2dcrsu, z2dcrsv 
    79       REAL(wp)       :: zmin,zmax,icnt1,icnt2 
     81      REAL(wp)       :: z1_2dt 
     82      REAL(wp)       :: icnt1,icnt2 
    8083      INTEGER :: i,j,ijis,ijie,ijjs,ijje 
    8184      REAL(wp)       :: zw,zwp1,zum1,zu,zvm1,zv,zsnm,zsm,z 
     
    8588      INTEGER ::  iji,ijj 
    8689      INTEGER :: jl,jm,jn 
     90      REAL(wp)       :: zmin,zmax,zsuma0,zsuma1,zsuma2,zsuma3,zsumb0,zsumb1,zsumb2,zsumb3,zsumb4 
    8791      !! 
    8892      !!---------------------------------------------------------------------- 
     
    101105      CALL wrk_alloc( jpi_crs, jpj_crs, z2d_crs     ) 
    102106 
    103       ! Depth work arrrays 
    104       zfse3t(:,:,:) = fse3t(:,:,:) 
    105       zfse3u(:,:,:) = fse3u(:,:,:) 
    106       zfse3v(:,:,:) = fse3v(:,:,:) 
    107       zfse3w(:,:,:) = fse3w(:,:,:) 
    108107 
    109108      IF( kt == nit000  ) THEN 
     
    124123         emp_b_crs(:,:    ) = 0._wp    ! emp 
    125124         rnf_crs  (:,:    ) = 0._wp    ! runoff 
     125         rnf_b_crs(:,:    ) = 0._wp    ! runoff 
    126126         fr_i_crs (:,:    ) = 0._wp    ! ice cover 
    127127      ENDIF 
     
    129129      CALL iom_swap( "nemo_crs" )    ! swap on the coarse grid 
    130130 
    131       ! 2. Coarsen fields at each time step 
    132       ! -------------------------------------------------------- 
     131      !--------------------------------------------------------------------------------------------------- 
     132      !variables domaine au temps before : swap  
     133      !--------------------------------------------------------------------------------------------------- 
     134#if defined key_vvl 
     135      e3t_b_crs(:,:,:) = e3t_n_crs(:,:,:) 
     136      e3u_b_crs(:,:,:) = e3u_n_crs(:,:,:) 
     137      e3v_b_crs(:,:,:) = e3v_n_crs(:,:,:) 
     138      e3w_b_crs(:,:,:) = e3w_n_crs(:,:,:) 
     139      e3t_n_crs(:,:,:) = e3t_a_crs(:,:,:) 
     140      e3u_n_crs(:,:,:) = e3u_a_crs(:,:,:) 
     141      e3v_n_crs(:,:,:) = e3v_a_crs(:,:,:) 
     142      e3w_n_crs(:,:,:) = e3w_a_crs(:,:,:) 
     143#endif 
     144 
     145      IF( kt /= nit000 )THEN 
     146         tsb_crs(:,:,:,jp_tem) = tsn_crs(:,:,:,jp_tem)  
     147         tsb_crs(:,:,:,jp_sal) = tsn_crs(:,:,:,jp_sal)  
     148         ub_crs(:,:,:)         = un_crs(:,:,:)  
     149         vb_crs(:,:,:)         = vn_crs(:,:,:)  
     150         sshb_crs(:,:)         = sshb_crs(:,:) 
     151         emp_b_crs(:,:)        = emp_crs(:,:) 
     152         rnf_b_crs(:,:)        = rnf_crs(:,:) 
     153         rb2_crs(:,:,:)        = rn2_crs(:,:,:) 
     154      ENDIF 
     155 
     156      !--------------------------------------------------------------------------------------------------- 
     157      !variables domaine au temps now :  
     158      !--------------------------------------------------------------------------------------------------- 
     159#if defined key_vvl 
     160      zfse3t(:,:,:) = e3t_n(:,:,:) 
     161      zfse3u(:,:,:) = e3u_n(:,:,:) 
     162      zfse3v(:,:,:) = e3v_n(:,:,:) 
     163      zfse3w(:,:,:) = e3w_n(:,:,:) 
     164 
     165      CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=zfse3u ) 
     166      CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=zfse3v ) 
     167      !                                                                                  
     168      CALL crs_dom_e3( e1t, e2t, zfse3t, p_sfc_3d_crs=e1e2w_crs, cd_type='T', p_mask=tmask, p_e3_crs=zs_crs, p_e3_max_crs=e3t_max_0_crs) 
     169      CALL crs_dom_e3( e1t, e2t, zfse3w, p_sfc_3d_crs=e1e2w_crs, cd_type='W', p_mask=tmask, p_e3_crs=zs_crs, p_e3_max_crs=e3w_max_0_crs) 
     170      CALL crs_dom_e3( e1u, e2u, zfse3u, p_sfc_2d_crs=e2u_crs  , cd_type='U', p_mask=umask, p_e3_crs=zs_crs, p_e3_max_crs=e3u_max_0_crs) 
     171      CALL crs_dom_e3( e1v, e2v, zfse3v, p_sfc_2d_crs=e1v_crs  , cd_type='V', p_mask=vmask, p_e3_crs=zs_crs, p_e3_max_crs=e3v_max_0_crs) 
     172 
     173      CALL crs_dom_ope( gdepw_n, 'MAX', 'T', tmask, gdept_n_crs, p_e3=zfse3t, psgn=1.0 ) 
     174      CALL crs_dom_ope( gdepw_n, 'MAX', 'W', tmask, gdepw_n_crs, p_e3=zfse3w, psgn=1.0 ) 
     175 
     176      CALL crs_dom_facvol( tmask, 'T', e1t, e2t, zfse3t, ocean_volume_crs_t, facvol_t ) 
     177      CALL iom_put("ocean_volume_crs_t",ocean_volume_crs_t) 
     178      ! 
     179      bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:)*tmask_crs(:,:,:) 
     180      ! 
     181      r1_bt_crs(:,:,:) = 0._wp 
     182      WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp / bt_crs(:,:,:) 
     183 
     184      CALL crs_dom_facvol( tmask, 'W', e1t, e2t, zfse3w, ocean_volume_crs_w, facvol_w ) 
     185 
     186#endif 
     187 
     188#if defined key_vvl 
     189      zfse3t(:,:,:) = e3t_n(:,:,:) 
     190      zfse3u(:,:,:) = e3u_n(:,:,:) 
     191      zfse3v(:,:,:) = e3v_n(:,:,:) 
     192      zfse3w(:,:,:) = e3w_n(:,:,:) 
     193      CALL iom_put("e3t",e3t_n_crs) 
     194      CALL iom_put("e3u",e3u_n_crs) 
     195      CALL iom_put("e3v",e3v_n_crs) 
     196      CALL iom_put("e3w",e3w_n_crs) 
     197#else 
     198      zfse3t(:,:,:) = e3t_0(:,:,:) 
     199      zfse3u(:,:,:) = e3u_0(:,:,:) 
     200      zfse3v(:,:,:) = e3v_0(:,:,:) 
     201      zfse3w(:,:,:) = e3w_0(:,:,:) 
     202#endif 
    133203 
    134204      !  Temperature 
    135       zt(:,:,:) = tsb(:,:,:,jp_tem)  ;      zt_crs(:,:,:) = 0._wp 
    136       CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 
    137       tsb_crs(:,:,:,jp_tem) = zt_crs(:,:,:) 
    138205      zt(:,:,:) = tsn(:,:,:,jp_tem)  ;      zt_crs(:,:,:) = 0._wp 
    139206      CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 
     
    143210      CALL iom_put( "sst" , tsn_crs(:,:,1,jp_tem) )    ! sst 
    144211 
    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  
    151212      !  Salinity 
    152       zs(:,:,:) = tsb(:,:,:,jp_sal)  ;      zs_crs(:,:,:) = 0._wp 
    153       CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 
    154       tsb_crs(:,:,:,jp_sal) = zs_crs(:,:,:) 
    155213      zs(:,:,:) = tsn(:,:,:,jp_sal)  ;      zs_crs(:,:,:) = 0._wp 
    156214      CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 
     
    161219 
    162220      !  U-velocity 
    163       CALL crs_dom_ope( ub, 'SUM', 'U', umask, ub_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 
    164221      CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 
    165       !cbr 
    166       ub_crs(:,:,:) = ub_crs(:,:,:)*umask_crs(:,:,:) 
    167222      un_crs(:,:,:) = un_crs(:,:,:)*umask_crs(:,:,:) 
    168       ! 
    169       zt(:,:,:) = 0._wp     ;    zs(:,:,:) = 0._wp  ;   zt_crs(:,:,:) = 0._wp   ;    zs_crs(:,:,:) = 0._wp 
     223      CALL iom_put( "uoce"  , un_crs )   ! i-current  
     224 
     225      !  V-velocity 
     226      CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
     227      vn_crs(:,:,:) = vn_crs(:,:,:)*vmask_crs(:,:,:) 
     228      CALL iom_put( "voce"  , vn_crs )   ! i-current  
     229      
     230      !  Horizontal divergence ( following OPA_SRC/DYN/divcur.F90 )  
     231      hdivn_crs(:,:,:)=0._wp 
     232 
    170233      DO jk = 1, jpkm1 
    171          DO jj = 2, jpjm1 
    172             DO ji = 2, jpim1    
    173                zt(ji,jj,jk)  = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) )  
    174                zs(ji,jj,jk)  = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) )  
    175             END DO 
    176          END DO 
    177       END DO 
    178       CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 
    179       CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 
    180  
    181       CALL iom_put( "uoce"  , un_crs )   ! i-current  
    182       CALL iom_put( "uocet" , zt_crs )   ! uT 
    183       CALL iom_put( "uoces" , zs_crs )   ! uS 
    184  
    185       !  V-velocity 
    186       CALL crs_dom_ope( vb, 'SUM', 'V', vmask, vb_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
    187       CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
    188       vb_crs(:,:,:) = vb_crs(:,:,:)*vmask_crs(:,:,:) 
    189       vn_crs(:,:,:) = vn_crs(:,:,:)*vmask_crs(:,:,:) 
    190       !                                                                                  
    191       zt(:,:,:) = 0._wp     ;    zs(:,:,:) = 0._wp  ;   zt_crs(:,:,:) = 0._wp   ;    zs_crs(:,:,:) = 0._wp 
    192       DO jk = 1, jpkm1 
    193          DO jj = 2, jpjm1 
    194             DO ji = 2, jpim1    
    195                zt(ji,jj,jk)  = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) )  
    196                zs(ji,jj,jk)  = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) )  
    197             END DO 
    198          END DO 
    199       END DO 
    200       CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
    201       CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
    202   
    203       CALL iom_put( "voce"  , vn_crs )   ! i-current  
    204       CALL iom_put( "vocet" , zt_crs )   ! vT 
    205       CALL iom_put( "voces" , zs_crs )   ! vS 
    206  
    207       
    208       !  Kinetic energy 
    209       CALL crs_dom_ope( rke, 'VOL', 'T', tmask, rke_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 
    210       CALL iom_put( "eken", rke_crs ) 
    211  
    212       !  Horizontal divergence ( following OPA_SRC/DYN/divcur.F90 )  
    213       DO jk = 1, jpkm1 
    214          DO ji = 2, jpi_crsm1 
    215             DO jj = 2, jpj_crsm1 
    216                IF( tmask_crs(ji,jj,jk ) > 0 ) THEN 
    217                   !z2dcrsu =  ( un_crs(ji  ,jj  ,jk) * crs_surfu_wgt(ji  ,jj  ,jk) ) & 
    218                   !   &     - ( un_crs(ji-1,jj  ,jk) * crs_surfu_wgt(ji-1,jj  ,jk) ) 
    219                   !z2dcrsv =  ( vn_crs(ji  ,jj  ,jk) * crs_surfv_wgt(ji  ,jj  ,jk) ) & 
    220                   !   &     - ( vn_crs(ji  ,jj-1,jk) * crs_surfv_wgt(ji  ,jj-1,jk) ) 
    221                   ! 
    222                   !IF( crs_volt_wgt(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / crs_volt_wgt(ji,jj,jk) 
    223                   z2dcrsu =  ( un_crs(ji  ,jj  ,jk) * e2e3u_msk(ji  ,jj  ,jk) ) & 
    224                      &     - ( un_crs(ji-1,jj  ,jk) * e2e3u_msk(ji-1,jj  ,jk) ) 
    225                   z2dcrsv =  ( vn_crs(ji  ,jj  ,jk) * e1e3v_msk(ji  ,jj  ,jk) ) & 
    226                      &     - ( vn_crs(ji  ,jj-1,jk) * e1e3v_msk(ji  ,jj-1,jk) ) 
    227                   ! 
    228                   !cbr 
    229                   !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 ) 
    230                   !bug2: mm test que bug1: on n'obtient tjs pas zero 
    231                   !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) 
    232                   !exp (117,211,74) : e1*e2*e3=235206030060.005 / ocean_volume_crs_t * facvol = 235205585307.810 
    233                   !                   e1*e2*e3-cean_volume_crs_t * facvol/(cean_volume_crs_t * facvol) ~1.e-6)   
    234                   IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) 
    235  
    236                   z2dcrsu =  ( ub_crs(ji  ,jj  ,jk) * e2e3u_msk(ji  ,jj  ,jk) ) & 
    237                      &     - ( ub_crs(ji-1,jj  ,jk) * e2e3u_msk(ji-1,jj  ,jk) ) 
    238                   z2dcrsv =  ( vb_crs(ji  ,jj  ,jk) * e1e3v_msk(ji  ,jj  ,jk) ) & 
    239                      &     - ( vb_crs(ji  ,jj-1,jk) * e1e3v_msk(ji  ,jj-1,jk) ) 
    240                   ! 
    241                   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) ) 
    242                ENDIF 
     234         DO jj = 2,jpj_crs 
     235            DO ji = 2,jpi_crs 
     236               z2dcrsu =  ( un_crs(ji  ,jj  ,jk) * e2e3u_msk(ji  ,jj  ,jk) ) & 
     237                 &      - ( un_crs(ji-1,jj  ,jk) * e2e3u_msk(ji-1,jj  ,jk) ) 
     238               z2dcrsv =  ( vn_crs(ji  ,jj  ,jk) * e1e3v_msk(ji  ,jj  ,jk) ) & 
     239                 &      - ( vn_crs(ji  ,jj-1,jk) * e1e3v_msk(ji  ,jj-1,jk) ) 
     240 
     241               hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) 
    243242            ENDDO 
    244243         ENDDO 
     
    248247      CALL iom_put( "hdiv", hdivn_crs )   
    249248 
    250  
    251       !  W-velocity 
    252       IF( ln_crs_wn ) THEN 
    253          CALL crs_dom_ope( wn, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 ) 
    254       ELSE 
    255         wn_crs(:,:,jpk) = 0._wp 
    256         DO jk = jpkm1, 1, -1 
    257            wn_crs(:,:,jk) = e1e2w_msk(:,:,jk+1)*wn_crs(:,:,jk+1) - hdivn_crs(:,:,jk) 
    258            WHERE( e1e2w_msk(:,:,jk) .NE. 0._wp )  wn_crs(:,:,jk) =  wn_crs(:,:,jk) /e1e2w_msk(:,:,jk)  
    259         ENDDO 
    260       ENDIF 
    261  
    262       CALL iom_put( "woce", wn_crs  )   ! vertical velocity 
    263       !  free memory 
    264249 
    265250      !  avt, avs 
     
    276261            CALL crs_dom_ope( avt, 'MED', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=zfse3w, psgn=1.0 ) 
    277262         CASE ( 5 ) 
     263#if defined key_zdftke 
    278264            CALL crs_dom_ope( en , 'VOL', 'W', tmask, en_crs, p_e12=e1e2t, p_e3=zfse3w, psgn=1.0 ) 
    279265            CALL crs_dom_ope( taum , 'SUM', 'T', tmask, taum_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
     
    282268            CALL tke_avn_crs 
    283269            CALL zdf_evd_crs(kt) 
     270#endif 
    284271         CASE ( 6 ) 
    285272 
     
    295282            CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 
    296283            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  
    299284            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  
    301285            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  
    303286 
    304287            zt(:,:,:) = 0._wp 
     
    310293            CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 
    311294            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  
    314295            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 
    316296            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 
    318297 
    319298            zt(:,:,:) = 0._wp 
     
    326305            CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 
    327306            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  
    330307            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 
    332308            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 
    334309 
    335310            zt(:,:,:) = 0._wp 
     
    342317            CALL crs_dom_ope( zt, 'VOL', 'W', tmask, zt_crs, p_e12=e1e2t, p_e3=ztmp, psgn=1.0 ) 
    343318            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  
    346319            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 
    348320            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 
    350321 
    351322            CALL iom_put( "avte_crs1", avte_crs(:,:,:,1) )   !  Kz 
     
    353324            CALL iom_put( "avte_crs3", avte_crs(:,:,:,3) )   !  Kz 
    354325            CALL iom_put( "avte_crs4", avte_crs(:,:,:,4) )   !  Kz 
    355 !---------------------  
     326 
    356327            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) 
    358328            CALL iom_put( "zs_crs", zs_crs )   !  Kzlogvol 
    359 !--------------------- ok 
    360329 
    361330            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) 
    363331            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 
    366332            avt_crs=zs_crs 
    367333 
     
    379345 
    380346  
    381 !-------------- 
    382347               zwgt(1:4)=0._wp 
    383348               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 !-------------- 
    385349               IF( SUM(zwgt(1:4)) .NE. 0._wp ) THEN   
    386350                  zmean = SUM( zwgt(1:4)*avte_crs(ji,jj,jk,1:4)) / SUM(zwgt(1:4) ) 
     
    390354                 zerr=1.e10 
    391355               ENDIF 
    392 !-------------- 
    393356 
    394357               zerr_crs(ji,jj,jk)=zerr 
     
    400363               IF( tmask_crs(ji,jj,jk) == 1 .AND.  zerr .LE. zerr0 .AND. zmean .GT. 0._wp ) icnt2=icnt2+1 
    401364 
    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 
     365            ENDDO 
     366            ENDDO 
     367            ENDDO 
     368 
    414369            CALL iom_put( "zt_crs", zt_crs )   !  Kz 
    415370            CALL iom_put( "zerr_crs", zerr_crs )   !  Kz 
     
    419374      CALL iom_put( "avt", avt_crs )   !  Kz 
    420375      
    421       !deja dasn step CALL zdf_mxl_crs(kt) 
    422  
    423   
    424       !  sbc fields   
    425  
    426       CALL crs_dom_ope( sshb , 'VOL', 'T', tmask, sshb_crs , p_e12=e1e2t, p_e3=zfse3t         , psgn=1.0 )   
    427376      CALL crs_dom_ope( sshn , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=zfse3t         , psgn=1.0 )   
    428       CALL crs_dom_ope( ssha , 'VOL', 'T', tmask, ssha_crs , p_e12=e1e2t, p_e3=zfse3t         , psgn=1.0 )   
    429377      CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u  , p_surf_crs=e2u_crs  , psgn=1.0 ) 
    430378      CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v  , p_surf_crs=e1v_crs  , psgn=1.0 ) 
     
    432380      CALL crs_dom_ope( rnf  , 'MAX', 'T', tmask, rnf_crs                                     , psgn=1.0 ) 
    433381      CALL crs_dom_ope( qsr  , 'SUM', 'T', tmask, qsr_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
    434       CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
     382#if defined key_vvl 
     383      CALL crs_dom_ope( gdepw_n, 'MAX', 'W', tmask, gdepw_n_crs, p_e3=zfse3w, psgn=1.0 ) 
     384#else 
     385      CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_0_crs, p_e3=zfse3w, psgn=1.0 ) 
     386#endif 
     387 
    435388      CALL crs_dom_ope( emp  , 'SUM', 'T', tmask, emp_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
     389 
    436390      CALL crs_dom_ope( fmmflx,'SUM', 'T', tmask, fmmflx_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
    437391      CALL crs_dom_ope( sfx  , 'SUM', 'T', tmask, sfx_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
     
    453407      CALL iom_put( "ice_cover", fr_i_crs )   ! ice cover output  
    454408 
     409#if defined key_vvl 
     410     !--------------------------------------------------------------------------------------------------- 
     411     !variables au temps after 
     412     !--------------------------------------------------------------------------------------------------- 
     413 
     414     zfse3t(:,:,:) = 1._wp 
     415     zt(:,:,:) = tmask(:,:,:) 
     416     ssha(:,:) = ssha(:,:) * tmask(:,:,1) 
     417     CALL crs_dom_ope( ssha , 'VOL', 'T', zt, ssha_crs , p_e12=e1e2t,  p_e3=zfse3t , psgn=1.0 ) 
     418     CALL crs_lbc_lnk( ssha_crs, 'T', 1.0 ) !!!!!!!!!!!!!!!!!!! pas utile !!!!!!!!!!!!!!!!!!!!!!!!! 
     419 
     420     zfse3t(:,:,:) = e3t_a(:,:,:) 
     421     zfse3u(:,:,:) = e3u_a(:,:,:) 
     422     zfse3v(:,:,:) = e3v_a(:,:,:) 
     423     CALL dom_vvl_interpol( zfse3t(:,:,:), zfse3w(:,:,:), 'W'   ) 
     424 
     425     CALL crs_dom_sfc( umask, 'U', zt_crs, zs_crs, p_e2=e2u, p_e3=zfse3u ) ! zt_crs=e2e3u_crs,zs_crs=e2e3u_msk 
     426     CALL crs_dom_sfc( vmask, 'V', zt_crs, zs_crs, p_e1=e2v, p_e3=zfse3v ) ! zt_crs=e1e3v_crs,zs_crs=e1e3v_msk 
     427     CALL crs_dom_e3( e1t, e2t, zfse3t, p_sfc_3d_crs=e1e2w_crs, cd_type='T', p_mask=tmask, p_e3_crs=e3t_a_crs, p_e3_max_crs=zs_crs) 
     428     CALL crs_dom_e3( e1t, e2t, zfse3w, p_sfc_3d_crs=e1e2w_crs, cd_type='W', p_mask=tmask, p_e3_crs=e3w_a_crs, p_e3_max_crs=zs_crs) 
     429     CALL crs_dom_e3( e1u, e2u, zfse3u, p_sfc_2d_crs=e2u_crs  , cd_type='U', p_mask=umask, p_e3_crs=e3u_a_crs, p_e3_max_crs=zs_crs) 
     430     CALL crs_dom_e3( e1v, e2v, zfse3v, p_sfc_2d_crs=e1v_crs  , cd_type='V', p_mask=vmask, p_e3_crs=e3v_a_crs, p_e3_max_crs=zs_crs) 
     431 
     432 
     433     DO jk = 1, jpk 
     434        DO ji = 1, jpi_crs 
     435           DO jj = 1, jpj_crs 
     436              IF( e3t_a_crs(ji,jj,jk) == 0._wp ) e3t_a_crs(ji,jj,jk) = e3t_1d(jk) 
     437              IF( e3w_a_crs(ji,jj,jk) == 0._wp ) e3w_a_crs(ji,jj,jk) = e3w_1d(jk) 
     438              IF( e3u_a_crs(ji,jj,jk) == 0._wp ) e3u_a_crs(ji,jj,jk) = e3t_1d(jk) 
     439              IF( e3v_a_crs(ji,jj,jk) == 0._wp ) e3v_a_crs(ji,jj,jk) = e3t_1d(jk) 
     440           ENDDO 
     441       ENDDO 
     442     ENDDO 
     443 
     444     !zt_crs=ocean_volume_crs_t ; zs_crs=facvol_t after time !!! 
     445     CALL crs_dom_facvol( tmask, 'T', e1t, e2t, zfse3t, zt_crs, zs_crs ) 
     446 
     447#endif 
     448 
     449#if defined key_vvl 
     450      z1_2dt = 1._wp / ( 2. * rdt )                         ! set time step size (Euler/Leapfrog) 
     451      IF( neuler == 0 .AND. kt == nit000 )   z1_2dt = 1._wp / rdt 
     452      wn_crs(:,:,jpk) = 0._wp 
     453      DO jk = jpkm1, 1, -1 
     454         wn_crs(:,:,jk) = wn_crs(:,:,jk+1)*e1e2w_msk(:,:,jk+1) - (  hdivn_crs(:,:,jk)                                   &