New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 6772 for branches/2015 – NEMO

Changeset 6772 for branches/2015


Ignore:
Timestamp:
2016-07-01T18:02:45+02:00 (8 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)                                   & 
     455               &                          + z1_2dt * e1e2w_crs(:,:,jk) * ( e3t_a_crs(:,:,jk) - e3t_b_crs(:,:,jk) ) ) * tmask_crs(:,:,jk) 
     456         WHERE( e1e2w_msk(:,:,jk) .NE. 0._wp )  wn_crs(:,:,jk) =  wn_crs(:,:,jk) /e1e2w_msk(:,:,jk) 
     457      ENDDO 
     458#else 
     459      IF( ln_crs_wn ) THEN 
     460         CALL crs_dom_ope( wn, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 ) 
     461      ELSE 
     462         wn_crs(:,:,jpk) = 0._wp 
     463         DO jk = jpkm1, 1, -1 
     464            wn_crs(:,:,jk) = e1e2w_msk(:,:,jk+1)*wn_crs(:,:,jk+1) - hdivn_crs(:,:,jk) 
     465            WHERE( e1e2w_msk(:,:,jk) .NE. 0._wp )  wn_crs(:,:,jk) =  wn_crs(:,:,jk) /e1e2w_msk(:,:,jk) 
     466         ENDDO 
     467       ENDIF 
     468 
     469#endif 
     470      CALL crs_lbc_lnk( wn_crs, 'W', 1.0 )   !!!!!!!pas utile, nan ?????????????????????? 
     471      wn_crs(:,:,:) = wn_crs(:,:,:) * tmask_crs(:,:,:) 
     472      CALL iom_put( "woce", wn_crs  )   ! vertical velocity 
     473 
    455474      !  free memory 
    456475      CALL wrk_dealloc( jpi, jpj, jpk, zfse3t, zfse3w ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90

    r6101 r6772  
    2121   USE lib_mpp 
    2222   USE ldftra_crs 
     23   USE ieee_arithmetic 
    2324 
    2425   IMPLICIT NONE 
    … …  
    3031#  include "domzgr_substitute.h90" 
    3132 
    32    !! $Id$ 
    3333CONTAINS 
    3434    
    … …  
    111111     rfacty_r = 1. / nn_facty 
    112112 
     113write(narea+200,*)"crsini0",nstop; call flush(narea+200) 
     114 
    113115     !--------------------------------------------------------- 
    114116     ! 2. Define Global Dimensions of the coarsened grid 
    115117     !--------------------------------------------------------- 
    116118     CALL crs_dom_def       
     119write(narea+200,*)"crsini1",nstop; call flush(narea+200) 
    117120 
    118121     !--------------------------------------------------------- 
    … …  
    125128  
    126129     CALL crs_dom_msk 
    127  
     130write(narea+200,*)"crsini2",nstop; call flush(narea+200) 
     131      CALL mppsync() 
     132 
     133     !IF( narea==279 )THEN 
     134     !WRITE(narea+200,*)"tutu1 ",jpi,jpj,nldi,nlei,nldj,nlej 
     135     !DO jj=1,jpj 
     136     !   WRITE(narea+200,*)"tutu2 ",jj,MINVAL(tmask(:,jj,:)),MAXVAL(tmask(:,jj,:)) 
     137     !ENDDO 
     138     !ENDIF 
    128139 
    129140     !  3.b. Get the coordinates 
    … …  
    131142     !      Even-numbered reduction factor, center coordinate on U-,V- faces or f-corner. 
    132143     !       
    133      IF ( nresty /= 0 .AND. nrestx /= 0 ) THEN 
     144     !IF ( nresty /= 0 .AND. nrestx /= 0 ) THEN 
    134145        CALL crs_dom_coordinates( gphit, glamt, 'T', gphit_crs, glamt_crs )  
    135146        CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs )        
    136147        CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs )  
    137148        CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs )  
    138      ELSEIF ( nresty /= 0 .AND. nrestx == 0 ) THEN 
    139         CALL crs_dom_coordinates( gphiu, glamu, 'T', gphit_crs, glamt_crs ) 
    140         CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) 
    141         CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) 
    142         CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 
    143      ELSEIF ( nresty == 0 .AND. nrestx /= 0 ) THEN 
    144         CALL crs_dom_coordinates( gphiv, glamv, 'T', gphit_crs, glamt_crs ) 
    145         CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) 
    146         CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) 
    147         CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 
    148      ELSE  
    149         CALL crs_dom_coordinates( gphif, glamf, 'T', gphit_crs, glamt_crs ) 
    150         CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) 
    151         CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) 
    152         CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 
    153      ENDIF 
    154  
     149     !ELSEIF ( nresty /= 0 .AND. nrestx == 0 ) THEN 
     150     !   CALL crs_dom_coordinates( gphiu, glamu, 'T', gphit_crs, glamt_crs ) 
     151     !   CALL crs_dom_coordinates( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) 
     152     !   CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) 
     153     !   CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 
     154     !ELSEIF ( nresty == 0 .AND. nrestx /= 0 ) THEN 
     155     !   CALL crs_dom_coordinates( gphiv, glamv, 'T', gphit_crs, glamt_crs ) 
     156     !   CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) 
     157     !   CALL crs_dom_coordinates( gphiv, glamv, 'V', gphiv_crs, glamv_crs ) 
     158     !   CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 
     159     !ELSE  
     160     !   CALL crs_dom_coordinates( gphif, glamf, 'T', gphit_crs, glamt_crs ) 
     161     !   CALL crs_dom_coordinates( gphif, glamf, 'U', gphiu_crs, glamu_crs ) 
     162     !   CALL crs_dom_coordinates( gphif, glamf, 'V', gphiv_crs, glamv_crs ) 
     163     !   CALL crs_dom_coordinates( gphif, glamf, 'F', gphif_crs, glamf_crs ) 
     164     !ENDIF 
     165      CALL mppsync() 
     166 
     167write(narea+200,*)"crsini3",nstop; call flush(narea+200) 
    155168 
    156169     !  3.c. Get the horizontal mesh 
    … …  
    162175     CALL crs_dom_hgr( e1v, e2v, 'V', e1v_crs, e2v_crs ) 
    163176     CALL crs_dom_hgr( e1f, e2f, 'F', e1f_crs, e2f_crs ) 
     177 
     178     DO ji=nldi_crs,nlei_crs 
     179     DO jj=nldj_crs,nlej_crs 
     180        IF( e1t_crs(ji,jj)==0._wp .AND. tmask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e1t_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     181        IF( e1u_crs(ji,jj)==0._wp .AND. umask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e1u_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     182        IF( e1v_crs(ji,jj)==0._wp .AND. vmask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e1v_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     183        IF( e1f_crs(ji,jj)==0._wp .AND. fmask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e1f_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     184        IF( e2t_crs(ji,jj)==0._wp .AND. tmask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e2t_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     185        IF( e2u_crs(ji,jj)==0._wp .AND. umask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e2u_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     186        IF( e2v_crs(ji,jj)==0._wp .AND. vmask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e2v_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     187        IF( e2f_crs(ji,jj)==0._wp .AND. fmask_crs(ji,jj,1) .NE. 0._wp )WRITE(narea+8000-1,*)"e2f_crs=0",ji,jj;CALL FLUSH(narea+8000-1)  
     188     ENDDO 
     189     ENDDO 
     190 
    164191 
    165192     WHERE(e1t_crs == 0._wp) e1t_crs=r_inf 
    … …  
    172199     WHERE(e2f_crs == 0._wp) e2f_crs=r_inf 
    173200 
     201     zmin=MINVAL(e1t_crs,mask=(tmask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1t_crs,mask=(tmask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1t_crs ",zmin,zmax 
     202     zmin=MINVAL(e1u_crs,mask=(umask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1u_crs,mask=(umask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1u_crs ",zmin,zmax 
     203     zmin=MINVAL(e1v_crs,mask=(vmask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1v_crs,mask=(vmask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1v_crs ",zmin,zmax 
     204     zmin=MINVAL(e1f_crs,mask=(fmask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1f_crs,mask=(fmask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1f_crs ",zmin,zmax 
     205     zmin=MINVAL(e2t_crs,mask=(tmask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e2t_crs,mask=(tmask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e2t_crs ",zmin,zmax 
     206     zmin=MINVAL(e2u_crs,mask=(umask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e2u_crs,mask=(umask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e2u_crs ",zmin,zmax 
     207     zmin=MINVAL(e2v_crs,mask=(vmask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e2v_crs,mask=(vmask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e2v_crs ",zmin,zmax 
     208     zmin=MINVAL(e2f_crs,mask=(fmask_crs(:,:,1)==1));CALL mpp_min(zmin);zmax=MAXVAL(e2f_crs,mask=(fmask_crs(:,:,1)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e2f_crs ",zmin,zmax 
     209 
     210 
    174211     e1e2t_crs(:,:) = e1t_crs(:,:) * e2t_crs(:,:) 
    175212      
     213write(narea+200,*)"crsini4",nstop; call flush(narea+200) 
    176214      
    177215     !      3.c.2 Coriolis factor   
    … …  
    196234     CALL wrk_alloc(jpi, jpj, jpk, zfse3t, zfse3u, zfse3v, zfse3w ) 
    197235     ! 
    198      zfse3t(:,:,:) = fse3t(:,:,:) 
    199      zfse3u(:,:,:) = fse3u(:,:,:) 
    200      zfse3v(:,:,:) = fse3v(:,:,:) 
    201      zfse3w(:,:,:) = fse3w(:,:,:) 
     236     zfse3t(:,:,:) = e3t_0(:,:,:) !fse3t(:,:,:) 
     237     zfse3u(:,:,:) = e3u_0(:,:,:) !fse3u(:,:,:) 
     238     zfse3v(:,:,:) = e3v_0(:,:,:) !fse3v(:,:,:) 
     239     zfse3w(:,:,:) = e3w_0(:,:,:) !fse3w(:,:,:) 
    202240 
    203241     !    3.d.2   Surfaces  
    … …  
    209247     CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=zfse3u ) 
    210248     CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=zfse3v ) 
     249 
     250     DO ji=nldi_crs,nlei_crs 
     251     DO jj=nldj_crs,nlej_crs 
     252     DO jk=1,jpk    
     253        IF( e1e2w_crs(ji,jj,jk)==0._wp .AND. tmask_crs(ji,jj,jk)==1._wp )WRITE(narea+8000-1,*)"e1e2w_crs=0",ji,jj,jk;CALL FLUSH(narea+8000-1) 
     254        IF( e1e2w_msk(ji,jj,jk)==0._wp .AND. tmask_crs(ji,jj,jk)==1._wp )WRITE(narea+8000-1,*)"e1e2w_msk=0",ji,jj,jk;CALL FLUSH(narea+8000-1) 
     255        IF( e2e3u_crs(ji,jj,jk)==0._wp .AND. umask_crs(ji,jj,jk)==1._wp )WRITE(narea+8000-1,*)"e2e3u_crs=0",ji,jj,jk;CALL FLUSH(narea+8000-1) 
     256        IF( e2e3u_msk(ji,jj,jk)==0._wp .AND. umask_crs(ji,jj,jk)==1._wp )WRITE(narea+8000-1,*)"e2e3u_msk=0",ji,jj,jk;CALL FLUSH(narea+8000-1) 
     257        IF( e1e3v_crs(ji,jj,jk)==0._wp .AND. vmask_crs(ji,jj,jk)==1._wp )WRITE(narea+8000-1,*)"e1e3v_crs=0",ji,jj,jk;CALL FLUSH(narea+8000-1) 
     258        IF( e1e3v_msk(ji,jj,jk)==0._wp .AND. vmask_crs(ji,jj,jk)==1._wp )WRITE(narea+8000-1,*)"e1e3v_msk=0",ji,jj,jk;CALL FLUSH(narea+8000-1) 
     259     ENDDO 
     260     ENDDO 
     261     ENDDO 
     262write(narea+200,*)"crsini5",nstop; call flush(narea+200) 
     263 
     264!     WHERE(e1e2w_crs == 0._wp) e1e2w_crs=r_inf 
     265!     WHERE(e2e3u_crs == 0._wp) e2e3u_crs=r_inf 
     266!     WHERE(e1e3v_crs == 0._wp) e1e3v_crs=r_inf 
     267!     WHERE(e1e2w_msk == 0._wp) e1e2w_msk=r_inf 
     268!     WHERE(e2e3u_msk == 0._wp) e2e3u_msk=r_inf 
     269!     WHERE(e1e3v_msk == 0._wp) e1e3v_msk=r_inf 
     270     zmin=MINVAL(e1e2w_crs,mask=(tmask_crs(:,:,:)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1e2w_crs,mask=(tmask_crs(:,:,:)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1e2w_crs ",zmin,zmax 
     271     zmin=MINVAL(e2e3u_crs,mask=(umask_crs(:,:,:)==1));CALL mpp_min(zmin);zmax=MAXVAL(e2e3u_crs,mask=(umask_crs(:,:,:)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e2e3u_crs ",zmin,zmax 
     272     zmin=MINVAL(e1e3v_crs,mask=(vmask_crs(:,:,:)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1e3v_crs,mask=(vmask_crs(:,:,:)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1e3v_crs ",zmin,zmax 
     273     zmin=MINVAL(e1e2w_msk,mask=(tmask_crs(:,:,:)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1e2w_msk,mask=(tmask_crs(:,:,:)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1e2w_msk ",zmin,zmax 
     274     zmin=MINVAL(e2e3u_msk,mask=(umask_crs(:,:,:)==1));CALL mpp_min(zmin);zmax=MAXVAL(e2e3u_msk,mask=(umask_crs(:,:,:)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e2e3u_msk ",zmin,zmax 
     275     zmin=MINVAL(e1e3v_msk,mask=(vmask_crs(:,:,:)==1));CALL mpp_min(zmin);zmax=MAXVAL(e1e3v_msk,mask=(vmask_crs(:,:,:)==1));CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"crs e1e3v_msk ",zmin,zmax 
    211276    
    212277     !cbr facsurfu(:,:,:) = umask_crs(:,:,:) * e2e3u_msk(:,:,:) / e2e3u_crs(:,:,:) 
    … …  
    226291     ENDDO 
    227292 
     293        DO ji=nldi_crs,nlei_crs 
     294           DO jj=nldj_crs,nlej_crs 
     295        IF( ABS(e2u_crs(ji,jj)) .LE. 1.e-5 )WRITE(narea+8000-1,*)"UNDERFLOW e2u_crs",ji,jj,e2u_crs(ji,jj),umask_crs(ji,jj,1) ; CALL FLUSH(narea+8000-1) 
     296        IF( ABS(e1v_crs(ji,jj)) .LE. 1.e-5 )WRITE(narea+8000-1,*)"UNDERFLOW e1v_crs",ji,jj,e1v_crs(ji,jj),vmask_crs(ji,jj,1) ; CALL FLUSH(narea+8000-1) 
     297           ENDDO 
     298        ENDDO 
     299 
     300 
    228301     !    3.d.3   Vertical scale factors 
    229302     ! 
    230     
    231    
    232      CALL crs_dom_e3( e1t, e2t, zfse3t, e1e2w_crs, 'T', tmask, e3t_crs, e3t_max_crs) 
    233      CALL crs_dom_e3( e1u, e2u, zfse3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs) 
    234      CALL crs_dom_e3( e1v, e2v, zfse3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) 
    235      CALL crs_dom_e3( e1t, e2t, zfse3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs) 
    236      WHERE(e3t_max_crs == 0._wp) e3t_max_crs=r_inf 
    237      WHERE(e3u_max_crs == 0._wp) e3u_max_crs=r_inf 
    238      WHERE(e3v_max_crs == 0._wp) e3v_max_crs=r_inf 
    239      WHERE(e3w_max_crs == 0._wp) e3w_max_crs=r_inf 
    240  
     303     zmin=MINVAL(e2u_crs(nldi_crs:nlei_crs,nldj_crs:nlej_crs));zmax=MAXVAL(e2u_crs(nldi_crs:nlei_crs,nldj_crs:nlej_crs));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"e2u_crs",zmin,zmax;CALL FLUSH(numout)   
     304     zmin=MINVAL(e1v_crs(nldi_crs:nlei_crs,nldj_crs:nlej_crs));zmax=MAXVAL(e1v_crs(nldi_crs:nlei_crs,nldj_crs:nlej_crs));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"e1v_crs",zmin,zmax;CALL FLUSH(numout)   
     305     zmin=MINVAL(e1e2w_crs(nldi_crs:nlei_crs,nldj_crs:nlej_crs,:));zmax=MAXVAL(e1e2w_crs(nldi_crs:nlei_crs,nldj_crs:nlej_crs,:));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"e1e2w_crs",zmin,zmax;CALL FLUSH(numout)   
     306     zmin=MINVAL(zfse3u);zmax=MAXVAL(zfse3u);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"zfse3u",zmin,zmax;CALL FLUSH(numout)   
     307     zmin=MINVAL(zfse3v);zmax=MAXVAL(zfse3v);CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"zfse3v",zmin,zmax;CALL FLUSH(numout)   
     308 
     309     CALL crs_dom_e3( e1t, e2t, zfse3t, p_sfc_3d_crs=e1e2w_crs, cd_type='T', p_mask=tmask, p_e3_crs=e3t_0_crs, p_e3_max_crs=e3t_max_0_crs) 
     310     CALL crs_dom_e3( e1t, e2t, zfse3w, p_sfc_3d_crs=e1e2w_crs, cd_type='W', p_mask=tmask, p_e3_crs=e3w_0_crs, p_e3_max_crs=e3w_max_0_crs) 
     311     CALL crs_dom_e3( e1u, e2u, zfse3u, p_sfc_2d_crs=e2u_crs  , cd_type='U', p_mask=umask, p_e3_crs=e3u_0_crs, p_e3_max_crs=e3u_max_0_crs) 
     312     CALL crs_dom_e3( e1v, e2v, zfse3v, p_sfc_2d_crs=e1v_crs  , cd_type='V', p_mask=vmask, p_e3_crs=e3v_0_crs, p_e3_max_crs=e3v_max_0_crs) 
     313     WHERE(e3t_max_0_crs == 0._wp) e3t_max_0_crs=r_inf 
     314     WHERE(e3u_max_0_crs == 0._wp) e3u_max_0_crs=r_inf 
     315     WHERE(e3v_max_0_crs == 0._wp) e3v_max_0_crs=r_inf 
     316     WHERE(e3w_max_0_crs == 0._wp) e3w_max_0_crs=r_inf 
     317 
     318write(narea+200,*)"crsini6",nstop; call flush(narea+200) 
     319#if defined key_vvl 
     320     e3t_max_n_crs=e3t_max_0_crs 
     321     e3u_max_n_crs=e3u_max_0_crs 
     322     e3v_max_n_crs=e3v_max_0_crs 
     323     e3w_max_n_crs=e3w_max_0_crs 
     324#endif 
     325 
     326     ht_0_crs(:,:)=0._wp 
     327     DO jk = 1, jpk 
     328        ht_0_crs(:,:)=ht_0_crs(:,:)+e3t_0_crs(:,:,jk)*tmask_crs(:,:,jk) 
     329     ENDDO 
     330 
     331#if defined key_vvl 
     332     e3t_0_crs(:,:,:) = e3t_0_crs(:,:,:) * tmask_crs(:,:,:) 
     333     e3u_0_crs(:,:,:) = e3u_0_crs(:,:,:) * umask_crs(:,:,:) 
     334     e3v_0_crs(:,:,:) = e3v_0_crs(:,:,:) * vmask_crs(:,:,:) 
     335     e3w_0_crs(:,:,:) = e3w_0_crs(:,:,:) * tmask_crs(:,:,:) 
     336#endif 
     337 
     338write(narea+200,*)"crsini7",nstop; call flush(narea+200) 
    241339     ! Reset 0 to e3t_0 or e3w_0 
    242340     DO jk = 1, jpk 
    243341        DO ji = 1, jpi_crs 
    244342           DO jj = 1, jpj_crs 
    245               IF( e3t_crs(ji,jj,jk) == 0._wp ) e3t_crs(ji,jj,jk) = e3t_1d(jk) 
    246               IF( e3w_crs(ji,jj,jk) == 0._wp ) e3w_crs(ji,jj,jk) = e3w_1d(jk) 
    247               IF( e3u_crs(ji,jj,jk) == 0._wp ) e3u_crs(ji,jj,jk) = e3t_1d(jk) 
    248               IF( e3v_crs(ji,jj,jk) == 0._wp ) e3v_crs(ji,jj,jk) = e3t_1d(jk) 
     343              IF( e3t_0_crs(ji,jj,jk) == 0._wp ) e3t_0_crs(ji,jj,jk) = e3t_1d(jk) 
     344              IF( e3w_0_crs(ji,jj,jk) == 0._wp ) e3w_0_crs(ji,jj,jk) = e3w_1d(jk) 
     345              IF( e3u_0_crs(ji,jj,jk) == 0._wp ) e3u_0_crs(ji,jj,jk) = e3t_1d(jk) 
     346              IF( e3v_0_crs(ji,jj,jk) == 0._wp ) e3v_0_crs(ji,jj,jk) = e3t_1d(jk) 
    249347           ENDDO 
    250348        ENDDO 
    251349     ENDDO 
    252350 
     351#if defined key_vvl 
     352     e3t_b_crs(:,:,:) = e3t_0_crs(:,:,:) 
     353     e3u_b_crs(:,:,:) = e3u_0_crs(:,:,:) 
     354     e3v_b_crs(:,:,:) = e3v_0_crs(:,:,:) 
     355     e3w_b_crs(:,:,:) = e3w_0_crs(:,:,:) 
     356 
     357     e3t_n_crs(:,:,:) = e3t_0_crs(:,:,:) 
     358     e3u_n_crs(:,:,:) = e3u_0_crs(:,:,:) 
     359     e3v_n_crs(:,:,:) = e3v_0_crs(:,:,:) 
     360     e3w_n_crs(:,:,:) = e3w_0_crs(:,:,:) 
     361 
     362     e3t_a_crs(:,:,:) = e3t_0_crs(:,:,:) 
     363     e3u_a_crs(:,:,:) = e3u_0_crs(:,:,:) 
     364     e3v_a_crs(:,:,:) = e3v_0_crs(:,:,:) 
     365     e3w_a_crs(:,:,:) = e3w_0_crs(:,:,:) 
     366#endif 
     367 
    253368     !    3.d.3   Vertical depth (meters) 
    254369     !cbr: il semblerait que p_e3=... ne soit pas utile ici !!!!!!!!! 
    255      CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=zfse3t, psgn=1.0 )  
    256      CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=zfse3w, psgn=1.0 ) 
     370     CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_0_crs, p_e3=zfse3t, psgn=1.0 )  
     371     CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_0_crs, p_e3=zfse3w, psgn=1.0 ) 
     372#if defined key_vvl 
     373     gdept_n_crs(:,:,:) = gdept_0_crs(:,:,:) 
     374     gdepw_n_crs(:,:,:) = gdepw_0_crs(:,:,:) 
     375#endif 
     376 
     377write(narea+200,*)"crsini8",nstop; call flush(narea+200) 
    257378 
    258379     !--------------------------------------------------------- 
    … …  
    276397     !CALL dom_grid_glo   ! Return to parent grid domain 
    277398 
     399write(narea+200,*)"crsini9",nstop; call flush(narea+200) 
    278400 
    279401     ! 
    … …  
    291413      rhop_crs(:,:,:)=0._wp ; rhd_crs(:,:,:)=0._wp ; rb2_crs(:,:,:)=0._wp 
    292414 
     415write(narea+200,*)"crsini10",nstop; call flush(narea+200) 
    293416  
    294417     !--------------------------------------------------------- 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr_substitute.h90

    r4488 r6772  
    88   !!            3.1  !  2009-02  (G. Madec, M. Leclair)  pure z* coordinate 
    99   !!---------------------------------------------------------------------- 
     10 
    1011 
    1112#if defined key_vvl 
    … …  
    116117 
    117118#endif 
     119 
     120 
     121#if defined key_vvl 
     122! s* or z*-coordinate (3D + time dependency) + use of additional now arrays (..._n) 
     123 
     124#   define  fse3t_crs(i,j,k)   e3t_n_crs(i,j,k) 
     125#   define  fse3u_crs(i,j,k)   e3u_n_crs(i,j,k) 
     126#   define  fse3v_crs(i,j,k)   e3v_n_crs(i,j,k) 
     127#   define  fse3w_crs(i,j,k)   e3w_n_crs(i,j,k) 
     128 
     129#   define  fse3t_b_crs(i,j,k)   e3t_b_crs(i,j,k) 
     130#   define  fse3u_b_crs(i,j,k)   e3u_b_crs(i,j,k) 
     131#   define  fse3v_b_crs(i,j,k)   e3v_b_crs(i,j,k) 
     132#   define  fse3w_b_crs(i,j,k)   e3w_b_crs(i,j,k) 
     133#   define  fse3t_n_crs(i,j,k)   e3t_n_crs(i,j,k) 
     134#   define  fse3u_n_crs(i,j,k)   e3u_n_crs(i,j,k) 
     135#   define  fse3v_n_crs(i,j,k)   e3v_n_crs(i,j,k) 
     136#   define  fse3w_n_crs(i,j,k)   e3w_n_crs(i,j,k) 
     137#   define  fse3t_a_crs(i,j,k)   e3t_a_crs(i,j,k) 
     138#   define  fse3u_a_crs(i,j,k)   e3u_a_crs(i,j,k) 
     139#   define  fse3v_a_crs(i,j,k)   e3v_a_crs(i,j,k) 
     140#   define  fse3w_a_crs(i,j,k)   e3w_a_crs(i,j,k) 
     141 
     142#   define  fse3t_max_crs(i,j,k)   e3t_max_n_crs(i,j,k) 
     143#   define  fse3u_max_crs(i,j,k)   e3u_max_n_crs(i,j,k) 
     144#   define  fse3v_max_crs(i,j,k)   e3v_max_n_crs(i,j,k) 
     145#   define  fse3w_max_crs(i,j,k)   e3w_max_n_crs(i,j,k) 
     146 
     147#   define  fsdept_crs(i,j,k)   gdept_n_crs(i,j,k) 
     148#   define  fsdepw_crs(i,j,k)   gdepw_n_crs(i,j,k) 
     149 
     150#else 
     151! z- or s-coordinate (1D or 3D + no time dependency) use reference in all cases 
     152 
     153#   define  fse3t_crs(i,j,k)   e3t_0_crs(i,j,k) 
     154#   define  fse3u_crs(i,j,k)   e3u_0_crs(i,j,k) 
     155#   define  fse3v_crs(i,j,k)   e3v_0_crs(i,j,k) 
     156#   define  fse3w_crs(i,j,k)   e3w_0_crs(i,j,k) 
     157 
     158#   define  fse3t_b_crs(i,j,k)   e3t_0_crs(i,j,k) 
     159#   define  fse3u_b_crs(i,j,k)   e3u_0_crs(i,j,k) 
     160#   define  fse3v_b_crs(i,j,k)   e3v_0_crs(i,j,k) 
     161#   define  fse3w_b_crs(i,j,k)   e3w_0_crs(i,j,k) 
     162#   define  fse3t_n_crs(i,j,k)   e3t_0_crs(i,j,k) 
     163#   define  fse3u_n_crs(i,j,k)   e3u_0_crs(i,j,k) 
     164#   define  fse3v_n_crs(i,j,k)   e3v_0_crs(i,j,k) 
     165#   define  fse3w_n_crs(i,j,k)   e3w_0_crs(i,j,k) 
     166#   define  fse3t_a_crs(i,j,k)   e3t_0_crs(i,j,k) 
     167#   define  fse3u_a_crs(i,j,k)   e3u_0_crs(i,j,k) 
     168#   define  fse3v_a_crs(i,j,k)   e3v_0_crs(i,j,k) 
     169#   define  fse3w_a_crs(i,j,k)   e3w_0_crs(i,j,k) 
     170 
     171#   define  fse3t_max_crs(i,j,k)   e3t_max_0_crs(i,j,k) 
     172#   define  fse3u_max_crs(i,j,k)   e3u_max_0_crs(i,j,k) 
     173#   define  fse3v_max_crs(i,j,k)   e3v_max_0_crs(i,j,k) 
     174#   define  fse3w_max_crs(i,j,k)   e3w_max_0_crs(i,j,k) 
     175 
     176#   define  fsdept_crs(i,j,k)   gdept_0_crs(i,j,k) 
     177#   define  fsdepw_crs(i,j,k)   gdepw_0_crs(i,j,k) 
     178 
     179#endif 
     180 
     181 
     182 
    118183   !!---------------------------------------------------------------------- 
    119184   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r5602 r6772  
    7272   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    7373   PUBLIC   mpp_lnk_2d_9  
    74    PUBLIC   mppscatter, mppgather 
     74   PUBLIC   mppscatter, mppgather, mppgatheri 
    7575   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    7676   PUBLIC   mppsize 
    … …  
    14751475   END SUBROUTINE mppgather 
    14761476 
     1477   SUBROUTINE mppgatheri( ptab, kp, pio ) 
     1478      !!---------------------------------------------------------------------- 
     1479      !!                   ***  routine mppgather  *** 
     1480      !! 
     1481      !! ** Purpose :   Transfert between a local subdomain array and a work 
     1482      !!     array which is distributed following the vertical level. 
     1483      !! 
     1484      !!---------------------------------------------------------------------- 
     1485      INTEGER, DIMENSION(1,1),   INTENT(in   ) ::   ptab   ! subdomain input array 
     1486      INTEGER,                   INTENT(in   ) ::   kp     ! record length 
     1487      INTEGER, DIMENSION(jpnij), INTENT(  out) ::   pio    ! subdomain input array 
     1488      !! 
     1489      INTEGER :: itaille, ierror   ! temporary integer 
     1490      !!--------------------------------------------------------------------- 
     1491      ! 
     1492      itaille = 1 
     1493      CALL mpi_allgather( ptab, itaille, mpi_integer, pio, itaille     ,   & 
     1494         &                            mpi_integer, mpi_comm_opa, ierror ) 
     1495! CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr ) 
     1496      ! 
     1497   END SUBROUTINE mppgatheri 
     1498 
    14771499 
    14781500   SUBROUTINE mppscatter( pio, kp, ptab ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r5602 r6772  
    7272 
    7373      ! read namelist for ln_zco 
    74       NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco 
     74      NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav 
    7575 
    7676      !!---------------------------------------------------------------------- 
    … …  
    310310 
    311311         isurf = 0 
    312          DO jj = 1+jprecj, ilj-jprecj 
    313             DO  ji = 1+jpreci, ili-jpreci 
     312         DO jj = 1, ilj 
     313            DO  ji = 1, ili 
    314314               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 
    315315            END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r5602 r6772  
    464464      ENDIF 
    465465 
    466       CALL iom_put("zgru",zgru) 
    467       CALL iom_put("zgrv",zgrv) 
    468       CALL iom_put("zdzr",zdzr) 
    469       CALL iom_put("zwz",zwz) 
    470       CALL iom_put("zww",zww) 
    471       CALL iom_put("uslp",uslp) 
    472       CALL iom_put("vslp",vslp) 
    473        
    474466      CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 
    475467      CALL wrk_dealloc( jpi,jpj,     zhmlpu, zhmlpv) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp_crs.F90

    r6101 r6772  
    3535   USE crs 
    3636   USE iom 
     37   USE ieee_arithmetic 
    3738 
    3839   IMPLICIT NONE 
    … …  
    168169               !                                      ! bound the slopes: abs(zw.)<= 1/100 and zb..<0 
    169170               !                                      ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 
    170                zbu = MIN(  zbu, -100._wp* ABS( zau ) , -7.e+3_wp/e3u_max_crs(ji,jj,jk)* ABS( zau )  ) 
    171                zbv = MIN(  zbv, -100._wp* ABS( zav ) , -7.e+3_wp/e3v_max_crs(ji,jj,jk)* ABS( zav )  ) 
    172                !cc zbu = MIN(  zbu, -100._wp* ABS( zau ) , -7.e+3_wp/e3u_crs(ji,jj,jk)* ABS( zau )  ) 
    173                !cc zbv = MIN(  zbv, -100._wp* ABS( zav ) , -7.e+3_wp/e3v_crs(ji,jj,jk)* ABS( zav )  ) 
     171               zbu = MIN(  zbu, -100._wp* ABS( zau ) , -7.e+3_wp/fse3u_max_crs(ji,jj,jk)* ABS( zau )  ) 
     172               zbv = MIN(  zbv, -100._wp* ABS( zav ) , -7.e+3_wp/fse3v_max_crs(ji,jj,jk)* ABS( zav )  ) 
    174173               !                                      ! uslp and vslp output in zwz and zww, resp. 
    175174               zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) 
    … …  
    177176               zwz(ji,jj,jk) = ( ( 1. - zfi) * zau / ( zbu - zeps )                                              & 
    178177                  &                   + zfi  * uslpml(ji,jj)                                                     & 
    179                   &                          * 0.5_wp * ( gdept_crs(ji+1,jj,jk)+gdept_crs(ji,jj,jk) - e3u_max_crs(ji,jj,1) )   & 
     178                  &                          * 0.5_wp * ( fsdept_crs(ji+1,jj,jk)+fsdept_crs(ji,jj,jk) - fse3u_max_crs(ji,jj,1) )   & 
    180179                  &                          / MAX( hmlpt_crs(ji,jj), hmlpt_crs(ji+1,jj), 5._wp ) ) * umask_crs(ji,jj,jk) 
    181180               zww(ji,jj,jk) = ( ( 1. - zfj) * zav / ( zbv - zeps )                                              & 
    182181                  &                   + zfj  * vslpml(ji,jj)                                                     & 
    183                   &                          * 0.5_wp * ( gdept_crs(ji,jj+1,jk)+ gdept_crs(ji,jj,jk)-e3v_max_crs(ji,jj,1) )   & 
     182                  &                          * 0.5_wp * ( fsdept_crs(ji,jj+1,jk)+ fsdept_crs(ji,jj,jk)-fse3v_max_crs(ji,jj,1) )   & 
    184183                  &                          / MAX( hmlpt_crs(ji,jj), hmlpt_crs(ji,jj+1), 5. ) ) * vmask_crs(ji,jj,jk) 
    185184!!gm  modif to suppress omlmask.... (as in Griffies case) 
    … …  
    196195      END DO 
    197196      CALL crs_lbc_lnk( zwz, 'U', -1. )   ;   CALL crs_lbc_lnk( zww, 'V', -1. )      ! lateral boundary conditions 
    198       CALL iom_put("zwz_crs",zwz) 
    199       CALL iom_put("zww_crs",zww) 
    200197      ! 
    201198      !                                            !* horizontal Shapiro filter 
    … …  
    262259               !                                        ! bound the slopes: abs(zw.)<= 1/100 and zb..<0. 
    263260               !                                        ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 
    264                zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/e3w_max_crs(ji,jj,jk)* ABS( zai )  ) 
    265                zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w_max_crs(ji,jj,jk)* ABS( zaj )  ) 
     261               zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/fse3w_max_crs(ji,jj,jk)* ABS( zai )  ) 
     262               zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w_max_crs(ji,jj,jk)* ABS( zaj )  ) 
    266263               !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) 
    267264               zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0 
    268                zck = gdepw_crs(ji,jj,jk) / MAX( hmlp_crs(ji,jj), 10._wp ) 
     265               zck = fsdepw_crs(ji,jj,jk) / MAX( hmlp_crs(ji,jj), 10._wp ) 
    269266               zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk  ) * tmask_crs(ji,jj,jk) 
    270267               zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk  ) * tmask_crs(ji,jj,jk) 
    … …  
    333330      ! 
    334331      CALL iom_swap( "nemo_crs" )    ! swap on the coarse grid 
    335       CALL iom_put("zgru_crs",zgru) 
    336       CALL iom_put("zgrv_crs",zgrv) 
    337       CALL iom_put("zdzr_crs",zdzr) 
    338       CALL iom_put("zwz_crs",zwz) 
    339       CALL iom_put("zww_crs",zww) 
    340332      CALL iom_put("uslp_crs",uslp_crs) 
    341333      CALL iom_put("vslp_crs",vslp_crs) 
    … …  
    411403      !----------------------------------------------------------------------- 
    412404      ! 
    413       DO jj = 2, jpj_crsm1 
    414          DO ji = 2, jpi_crsm1 
     405      DO jj = 2, nldi_crs 
     406         DO ji = 2, nldj_crs 
    415407            !                        !==   Slope at u- & v-points just below the Mixed Layer   ==! 
    416408            ! 
    … …  
    425417            !                        !- bound the slopes: abs(zw.)<= 1/100 and zb..<0 
    426418            !                           kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 
    427             zbu = MIN(  zbu , -100._wp* ABS( zau ) , -7.e+3_wp/e3u_max_crs(ji,jj,iku)* ABS( zau )  ) 
    428             zbv = MIN(  zbv , -100._wp* ABS( zav ) , -7.e+3_wp/e3v_max_crs(ji,jj,ikv)* ABS( zav )  ) 
     419            zbu = MIN(  zbu , -100._wp* ABS( zau ) , -7.e+3_wp/fse3u_max_crs(ji,jj,iku)* ABS( zau )  ) 
     420            zbv = MIN(  zbv , -100._wp* ABS( zav ) , -7.e+3_wp/fse3v_max_crs(ji,jj,ikv)* ABS( zav )  ) 
    429421            !                        !- Slope at u- & v-points (uslpml, vslpml) 
    430422            uslpml(ji,jj) = zau / ( zbu - zeps ) * umask_crs(ji,jj,iku) 
    … …  
    448440            !                        !- bound the slopes: abs(zw.)<= 1/100 and zb..<0. 
    449441            !                           kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 
    450             zbi = MIN(  zbw , -100._wp* ABS( zai ) , -7.e+3_wp/e3w_max_crs(ji,jj,ik)* ABS( zai )  ) 
    451             zbj = MIN(  zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w_max_crs(ji,jj,ik)* ABS( zaj )  ) 
     442            zbi = MIN(  zbw , -100._wp* ABS( zai ) , -7.e+3_wp/fse3w_max_crs(ji,jj,ik)* ABS( zai )  ) 
     443            zbj = MIN(  zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w_max_crs(ji,jj,ik)* ABS( zaj )  ) 
    452444            !                        !- i- & j-slope at w-points (wslpiml, wslpjml) 
    453445            wslpiml(ji,jj) = zai / ( zbi - zeps ) * tmask_crs (ji,jj,ik) 
    … …  
    493485         ! 
    494486      ELSE                             ! Madec operator : slopes at u-, v-, and w-points 
    495          ALLOCATE( uslp_crs(jpi_crs,jpj_crs,jpk) , vslp_crs(jpi_crs,jpj_crs,jpk) , &  
    496                  & wslpi_crs(jpi_crs,jpj_crs,jpk) , wslpj_crs(jpi_crs,jpj_crs,jpk) ,  & 
    497                  & omlmask(jpi_crs,jpj_crs,jpk) ,  & 
    498                  & uslpml(jpi_crs,jpj_crs)   ,  vslpml(jpi_crs,jpj_crs)  , &  
    499                  & wslpiml(jpi_crs,jpj_crs)   , wslpjml(jpi_crs,jpj_crs) , STAT=ierr ) 
     487         ALLOCATE( uslp_crs(jpi_crs,jpj_crs,jpk) , vslp_crs(jpi_crs,jpj_crs,jpk) , wslpi_crs(jpi_crs,jpj_crs,jpk) , wslpj_crs(jpi_crs,jpj_crs,jpk) ,  & 
     488            &   omlmask(jpi_crs,jpj_crs,jpk) , uslpml(jpi_crs,jpj_crs)   , vslpml(jpi_crs,jpj_crs)    , wslpiml(jpi_crs,jpj_crs)   , wslpjml(jpi_crs,jpj_crs) , STAT=ierr ) 
    500489         IF( ierr > 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) 
    501490 
    … …  
    520509               DO jj = 2, jpj_crsm1 
    521510                  DO ji = 2, jpi_crsm1   ! vector opt. 
    522                   !cbr uslp_crs (ji,jj,jk) = -1./e1u_crs(ji,jj) * ( gdept_crs(ji+1,jj,jk) - gdept_crs(ji ,jj ,jk) ) * umask_crs(ji,jj,jk) 
    523                   !vslp_crs (ji,jj,jk) = -1./e2v_crs(ji,jj) * ( gdept_crs(ji,jj+1,jk) - gdept_crs(ji ,jj ,jk) ) * vmask_crs(ji,jj,jk) 
    524                   !wslpi_crs(ji,jj,jk) = -1./e1t_crs(ji,jj) * ( gdepw_crs(ji+1,jj,jk) - gdepw_crs(ji-1,jj,jk) ) * tmask_crs(ji,jj,jk) * 0.5 
    525                   !wslpj_crs(ji,jj,jk) = -1./e2t_crs(ji,jj) * ( gdepw_crs(ji,jj+1,jk) - gdepw_crs(ji,jj-1,jk) ) * tmask_crs(ji,jj,jk) * 0.5 
    526                   uslp_crs (ji,jj,jk) = -1. * ( gdept_crs(ji+1,jj,jk) - gdept_crs(ji ,jj ,jk) ) * umask_crs(ji,jj,jk) 
     511                  uslp_crs (ji,jj,jk) = -1. * ( fsdept_crs(ji+1,jj,jk) - fsdept_crs(ji ,jj ,jk) ) * umask_crs(ji,jj,jk) 
    527512                  IF( e1u_crs(ji,jj) .NE. 0._wp ) uslp_crs (ji,jj,jk) = uslp_crs (ji,jj,jk) / e1u_crs(ji,jj) 
    528                   vslp_crs (ji,jj,jk) = -1. * ( gdept_crs(ji,jj+1,jk) - gdept_crs(ji ,jj ,jk) ) * vmask_crs(ji,jj,jk) 
     513                  vslp_crs (ji,jj,jk) = -1. * ( fsdept_crs(ji,jj+1,jk) - fsdept_crs(ji ,jj ,jk) ) * vmask_crs(ji,jj,jk) 
    529514                  IF( e2v_crs(ji,jj) .NE. 0._wp ) vslp_crs (ji,jj,jk) = vslp_crs (ji,jj,jk) / e2v_crs(ji,jj) 
    530                   wslpi_crs(ji,jj,jk) = -1. * ( gdepw_crs(ji+1,jj,jk) - gdepw_crs(ji-1,jj,jk) ) * tmask_crs(ji,jj,jk) * 0.5 
     515                  wslpi_crs(ji,jj,jk) = -1. * ( fsdepw_crs(ji+1,jj,jk) - fsdepw_crs(ji-1,jj,jk) ) * tmask_crs(ji,jj,jk) * 0.5 
    531516                  IF( e1t_crs(ji,jj) .NE. 0._wp ) wslpi_crs(ji,jj,jk) =  wslpi_crs(ji,jj,jk) / e1t_crs(ji,jj) 
    532                   wslpj_crs(ji,jj,jk) = -1. * ( gdepw_crs(ji,jj+1,jk) - gdepw_crs(ji,jj-1,jk) ) * tmask_crs(ji,jj,jk) * 0.5 
     517                  wslpj_crs(ji,jj,jk) = -1. * ( fsdepw_crs(ji,jj+1,jk) - fsdepw_crs(ji,jj-1,jk) ) * tmask_crs(ji,jj,jk) * 0.5 
    533518                  IF( e2t_crs(ji,jj) .NE. 0._wp ) wslpj_crs(ji,jj,jk) = wslpj_crs(ji,jj,jk) / e2t_crs(ji,jj) 
    534519                  END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_crs.F90

    r6101 r6772  
    88   !!             2.0  ! 2005-11  (G. Madec)   
    99   !!---------------------------------------------------------------------- 
    10  
     10#if defined key_top && defined key_crs 
    1111   !!---------------------------------------------------------------------- 
    1212   !!   ldf_tra_init : initialization, namelist read, and parameters control 
    … …  
    8888 
    8989   !!====================================================================== 
     90#else 
     91   PUBLIC   ldf_tra_crs_init 
     92CONTAINS 
     93   SUBROUTINE ldf_tra_crs_init 
     94   END SUBROUTINE ldf_tra_crs_init 
     95 
     96#endif 
    9097END MODULE ldftra_crs 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r5602 r6772  
    4444   USE sbc_ice         ! Surface boundary condition: ice fields 
    4545   USE lib_fortran     ! to use key_nosignedzero 
     46   USE sbcapr 
    4647#if defined key_lim3 
    4748   USE ice, ONLY       : u_ice, v_ice, jpl, pfrld, a_i_b 
    4849   USE limthd_dh       ! for CALL lim_thd_snwblow 
    4950#elif defined key_lim2 
    50    USE ice_2, ONLY     : u_ice, v_ice 
     51   USE ice_2, ONLY     : u_ice, v_ice, pfrld 
    5152   USE par_ice_2 
    5253#endif 
    … …  
    8384   REAL(wp), PARAMETER ::   Cice =    1.4e-3      ! iovi 1.63e-3     ! transfer coefficient over ice 
    8485   REAL(wp), PARAMETER ::   albo =    0.066       ! ocean albedo assumed to be constant 
     86   REAL(wp), PARAMETER ::   rgas =  287.1         ! gas const. dry air (J/kg/K) 
     87   REAL(wp), PARAMETER ::   rvap =  461.51        ! gas const. vapour  (J/kg/K) 
    8588 
    8689   !                                  !!* Namelist namsbc_core : CORE bulk parameters 
    … …  
    9194   REAL(wp) ::   rn_zqt      ! z(q,t) : height of humidity and temperature measurements 
    9295   REAL(wp) ::   rn_zu       ! z(u)   : height of wind measurements 
     96   ! 
     97   LOGICAL  ::   ln_tair_celsius  !: logical flag for Read Tair: Tair in NEMO is Kelvin 
     98   LOGICAL  ::   ln_humi_rel      !: logical flag for Read relative humidity (T) or specific humidity (F) 
     99   LOGICAL  ::   ln_cohum_arc     !: logical flag for Correction of Humidity in the Arctic Ocean 
     100   LOGICAL  ::   ln_cotair_arc    !: logical flag for Correction of Air Temperature in the Arctic Ocean 
     101   LOGICAL  ::   ln_corad_antar   !: logical flag for Correction of radiatives fluxes in the Southern Ocean 
     102 
    93103 
    94104   !! * Substitutions 
    … …  
    143153      INTEGER  ::   ios      ! Local integer output status for namelist read 
    144154      ! 
     155      INTEGER  ::   ji,jj 
     156      REAL(wp) ::   zzlat, zzlat1, zzlat2, zfm, zfrld 
     157      REAL(wp) ::   zmin,zmax 
     158      REAL(wp), DIMENSION(:,:), POINTER :: xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair 
     159      REAL(wp), DIMENSION(:,:), POINTER :: zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr 
     160      
    145161      CHARACTER(len=100) ::  cn_dir   !   Root directory for location of core files 
    146162      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i     ! array of namelist informations on the fields to read 
    … …  
    151167         &                  sn_wndi, sn_wndj, sn_humi  , sn_qsr ,           & 
    152168         &                  sn_qlw , sn_tair, sn_prec  , sn_snow,           & 
    153          &                  sn_tdif, rn_zqt,  rn_zu 
     169         &                  sn_tdif, rn_zqt,  rn_zu , ln_tair_celsius,   & 
     170         &                  ln_humi_rel  , ln_cohum_arc,      & 
     171         &                  ln_cotair_arc, ln_corad_antar 
     172 
    154173      !!--------------------------------------------------------------------- 
    155174      ! 
     175      CALL wrk_alloc( jpi,jpj, xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair ) 
     176      CALL wrk_alloc( jpi,jpj, zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr ) 
    156177      !                                         ! ====================== ! 
    157178      IF( kt == nit000 ) THEN                   !  First call kt=nit000  ! 
    … …  
    194215         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_core', 'flux formulation for ocean surface boundary condition', 'namsbc_core' ) 
    195216         ! 
     217         ! 
     218         IF(lwp) WRITE(numout,*) 'sbc_blk_core: jfld = ',jfld 
     219         IF( ln_cohum_arc   ) CALL ctl_warn( 'sbc_blk_core: correction of humidity in arctic' ) 
     220         IF( ln_cotair_arc  ) CALL ctl_warn( 'sbc_blk_core: correction of air temperature in arctic' ) 
     221         IF( ln_corad_antar ) CALL ctl_warn( 'sbc_blk_core: correction of short radiation in antartic' ) 
     222         IF( ln_humi_rel    ) CALL ctl_warn( 'sbc_blk_core: use relative humidity instead of specific humidity') 
     223         IF( ln_tair_celsius) CALL ctl_warn( 'sbc_blk_core: Tair is read in Celsius') 
     224         IF(lwp) WRITE(numout,*) 'sbc_blk_core: rn_pfac = ',rn_pfac 
     225         ! 
    196226         sfx(:,:) = 0._wp                          ! salt flux; zero unless ice is present (computed in limsbc(_2).F90) 
    197227         ! 
    … …  
    199229 
    200230      CALL fld_read( kt, nn_fsbc, sf )             ! input fields provided at the current time-step 
     231 
     232      !========================================= 
     233      !  ONLINE CORRECTIONS 
     234      !========================================= 
     235      ! 
     236      ! Correction of Tair 
     237      ! 
     238      IF( ln_tair_celsius .AND. MOD( kt-1, nn_fsbc ) == 0 ) THEN 
     239         sf(jp_tair)%fnow = sf(jp_tair)%fnow + 273.15_wp  ! Conversion of the Temperature °C --> Kelvin 
     240      ENDIF 
     241      ! 
     242      ! Correction of SW and LW in the Southern Ocean 
     243      ! 
     244      IF( ln_corad_antar .AND. .NOT. sf(jp_qsr)%ln_tint .AND. MOD( kt-1, 86400/INT(rdt) ) == 0 ) THEN 
     245         z_qsr(:,:) = 0.8 * sf(jp_qsr)%fnow(:,:,1) 
     246         xyt(:,:) = 0.e0 ; zzlat1 = -65. ; zzlat2 = -60. 
     247         DO jj = 1, jpj 
     248            DO ji = 1, jpi 
     249               zzlat = gphit(ji,jj) 
     250               IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 ) THEN 
     251                  xyt(ji,jj) = (zzlat2-zzlat)/(zzlat2-zzlat1) 
     252               ELSE IF ( zzlat < zzlat1 ) THEN 
     253                  xyt(ji,jj) = 1 
     254               ENDIF 
     255            END DO 
     256         END DO 
     257         IF(lwp) WRITE(numout,*) 'Correc ln_corad_antar' 
     258         z_qsr1(:,:) = z_qsr(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_qsr)%fnow(:,:,1) 
     259         sf(jp_qsr)%fnow(:,:,1) = z_qsr1(:,:) 
     260      ENDIF 
     261 
     262      IF( MOD( kt-1, nn_fsbc ) == 0 )THEN 
     263         ! 
     264         IF ( nmonth >= 5 .AND. nmonth <= 9 ) THEN 
     265            ! 
     266            ! Correction of Humidity in the Arctic Ocean 
     267            ! 
     268            IF( ln_cohum_arc ) THEN 
     269               z_hum(:,:) = 0.85 * sf(jp_humi)%fnow(:,:,1) 
     270               xyt(:,:) = 0.e0 ; zzlat1 = 78. ; zzlat2 = 82. 
     271               DO jj = 1, jpj 
     272                  DO ji = 1, jpi 
     273                     zzlat = gphit(ji,jj) 
     274#if defined key_lim2 ||  defined key_lim3  
     275                     IF ( ALLOCATED(pfrld) ) THEN ; zfrld = pfrld(ji,jj) ; ELSE ; zfrld = 0 ; ENDIF 
     276#endif 
     277                     IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 .AND. zfrld < 0.85 ) THEN 
     278                        xyt(ji,jj) = ( zzlat - zzlat1 ) / ( zzlat2 - zzlat1 ) 
     279                     ELSE IF ( zzlat > zzlat2 .AND. zfrld < 0.85 ) THEN 
     280                        xyt(ji,jj) = 1._wp 
     281                     ENDIF 
     282                  ENDDO 
     283               ENDDO 
     284               IF(lwp) WRITE(numout,*) 'Correc ln_cohum_arc' 
     285               sf(jp_humi)%fnow(:,:,1) = z_hum(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_humi)%fnow(:,:,1) 
     286            ENDIF 
     287            ! 
     288            ! Correction of Air Temperature in the Arctic Ocean 
     289            ! 
     290            IF( ln_cotair_arc ) THEN 
     291               z_tair(:,:) = sf(jp_tair)%fnow(:,:,1) - 2.0 
     292               xyt(:,:) = 0.e0 ; zzlat1 = 78. ; zzlat2 = 82. 
     293               DO jj = 1, jpj 
     294                  DO ji = 1, jpi 
     295                     zzlat = gphit(ji,jj) 
     296#if defined key_lim2 ||  defined key_lim3  
     297                     IF( ALLOCATED(pfrld) ) THEN ; zfrld = pfrld(ji,jj) ; ELSE ; zfrld=0 ; ENDIF 
     298#endif 
     299                     IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 .AND. zfrld < 0.85 ) THEN 
     300                        xyt(ji,jj) = ( zzlat - zzlat1 ) / ( zzlat2 - zzlat1 ) 
     301                     ELSE IF( zzlat > zzlat2 .AND. zfrld < 0.85 ) THEN 
     302                        xyt(ji,jj) = 1._wp 
     303                     ENDIF 
     304                  END DO 
     305               ENDDO 
     306               IF(lwp) WRITE(numout,*) 'Correc ln_cotair_arc' 
     307               sf(jp_tair)%fnow(:,:,1) = z_tair(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_tair)%fnow(:,:,1) 
     308            ENDIF 
     309            ! 
     310         ENDIF ! 5 <= nmonth <= 9 
     311 
     312         ! 
     313      ENDIF ! IF MOD( kt-1, nn_fsbc ) 
     314 
     315      DO jj=1,jpj 
     316         DO ji=1,jpi 
     317            sf(jp_humi)%fnow(ji,jj,1) = MAX( MIN( sf(jp_humi)%fnow(ji,jj,1) ,1.0 ) , 0.0 ) 
     318            sf(jp_prec)%fnow(ji,jj,1) = MAX(      sf(jp_prec)%fnow(ji,jj,1) ,0.0 ) 
     319            sf(jp_qsr )%fnow(ji,jj,1) = MAX(      sf(jp_qsr )%fnow(ji,jj,1) ,0.0 ) 
     320            sf(jp_qlw )%fnow(ji,jj,1) = MAX(      sf(jp_qlw )%fnow(ji,jj,1) ,0.0 ) 
     321         ENDDO 
     322      END DO 
     323 
     324      ! 
     325      !========================================= 
     326      ! END OF ONLINE CORRECTIONS 
     327      !========================================= 
     328      ! 
    201329 
    202330      !                                            ! compute the surface ocean fluxes using CORE bulk formulea 
    … …  
    215343      ENDIF 
    216344#endif 
     345      ! 
     346      CALL wrk_dealloc( jpi,jpj, xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair ) 
     347      CALL wrk_dealloc( jpi,jpj, zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr ) 
    217348      ! 
    218349   END SUBROUTINE sbc_blk_core 
    … …  
    257388      REAL(wp), DIMENSION(:,:), POINTER ::   zt_zu             ! air temperature at wind speed height 
    258389      REAL(wp), DIMENSION(:,:), POINTER ::   zq_zu             ! air spec. hum.  at wind speed height 
     390      REAL(wp), DIMENSION(:,:), POINTER ::   zqatm , zpatm     ! specific humidity and mean sea level pressure (Pa) 
     391      REAL(wp) :: vt, vp, vq, zqa, zq0, zq1, zq2, zee 
    259392      !!--------------------------------------------------------------------- 
    260393      ! 
    … …  
    262395      ! 
    263396      CALL wrk_alloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 
    264       CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
     397      CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ,zqatm, zpatm ) 
    265398      ! 
    266399      ! local scalars ( place there for vector optimisation purposes) 
    … …  
    314447      ! ... specific humidity at SST and IST 
    315448      zqsatw(:,:) = zcoef_qsatw * EXP( -5107.4 / zst(:,:) ) 
    316  
     449      ! 
     450      IF ( ln_humi_rel ) THEN 
     451         zq0    = rvap / rgas - 1.0 
     452         zq1    = rgas / rvap 
     453         zq2    = 1.0 - zq1 
     454         zpatm(:,:) = 100800.                   ! atmospheric pressure (assumed constant  here) 
     455         IF ( ln_apr_dyn ) zpatm(:,:) = apr(:,:) 
     456         DO jj = 1 , jpj 
     457            DO ji = 1 , jpi 
     458               vt  = sf(jp_tair)%fnow(ji,jj,1) - rt0  ! air temperature (Celsius) 
     459               vp  = zpatm(ji,jj) / 100.              ! mean sea level pressure (mb or hPa) 
     460               vq  = sf(jp_humi)%fnow(ji,jj,1)        ! relative humidity (fraction of 1) 
     461               ! Convert RH at the air/sea interface in specific humidity (kg/kg) 
     462               ! Teten's formula for qsat (mb) 
     463               zqa = ( 1.0007 + 3.46e-6 * vp) * 6.1121 * EXP( 17.502 * vt / ( 240.97+vt ) ) 
     464               zee = zqa * vq                         ! vapour partial pressure (mb) 
     465               vq  = zq1 * zee / ( vp - zq2 * zee )   ! specific humidity (kg/kg) 
     466               zqatm(ji,jj) = vq 
     467            ENDDO 
     468         ENDDO 
     469      ELSE 
     470         zqatm(:,:)=sf(jp_humi)%fnow(:,:,1) 
     471      ENDIF 
     472      ! 
    317473      ! ... NCAR Bulk formulae, computation of Cd, Ch, Ce at T-point : 
    318       CALL turb_core_2z( rn_zqt, rn_zu, zst, sf(jp_tair)%fnow, zqsatw, sf(jp_humi)%fnow, wndm,   & 
     474      CALL turb_core_2z( rn_zqt, rn_zu, zst, sf(jp_tair)%fnow, zqsatw, zqatm, wndm,   & 
    319475         &               Cd, Ch, Ce, zt_zu, zq_zu ) 
    320476     
    … …  
    354510      IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN 
    355511         !! q_air and t_air are (or "are almost") given at 10m (wind reference height) 
    356          zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) )*wndm(:,:) ) ! Evaporation 
     512         !zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) )*wndm(:,:) ) ! Evaporation 
     513          zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - zqatm(:,:)              )*wndm(:,:) ) ! Evaporation 
    357514         zqsb (:,:) =                     cpa*rhoa*Ch(:,:)*( zst   (:,:) - sf(jp_tair)%fnow(:,:,1) )*wndm(:,:)   ! Sensible Heat 
    358515      ELSE 
    … …  
    414571      ! 
    415572      CALL wrk_dealloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 
    416       CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
     573      CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu, zqatm, zpatm ) 
    417574      ! 
    418575      IF( nn_timing == 1 )  CALL timing_stop('blk_oce_core') 
    … …  
    437594      REAL(wp) ::             zwndi_t , zwndj_t               ! relative wind components at T-point 
    438595      !!--------------------------------------------------------------------- 
    439       ! 
     596 
    440597      IF( nn_timing == 1 )  CALL timing_start('blk_ice_core_tau') 
    441598      ! 
    … …  
    530687      REAL(wp) ::   zcoef_dqlw, zcoef_dqla, zcoef_dqsb 
    531688      REAL(wp) ::   zztmp, z1_lsub                               ! temporary variable 
     689      REAL(wp) ::   ztamr,zmt1,zmt2,zmt3,zev,zes 
    532690      !! 
    533691      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw             ! long wave heat flux over ice 
    … …  
    536694      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb            ! sensible  heat sensitivity over ice 
    537695      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw       ! evaporation and snw distribution after wind blowing (LIM3) 
     696      REAL(wp), DIMENSION(:,:)  , POINTER ::   zqatm, zpatm , ztatm            ! specific humidity 
    538697      !!--------------------------------------------------------------------- 
    539698      ! 
    … …  
    541700      ! 
    542701      CALL wrk_alloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb )  
     702      CALL wrk_alloc( jpi,jpj, zqatm, zpatm, ztatm ) 
     703  
     704     IF ( ln_humi_rel ) THEN 
     705         zpatm(:,:) = 100800.                   ! atmospheric pressure (assumed constant here) 
     706         IF (ln_apr_dyn) zpatm(:,:) = apr(:,:) 
     707         DO jj=1,jpj 
     708            DO ji=1,jpi 
     709               ztatm (ji,jj) = sf(jp_tair)%fnow(ji,jj,1)                   ! air temperature in Kelvins 
     710               ztamr = ztatm(ji,jj) - rtt                                  ! Saturation water vapour 
     711               zmt1  = SIGN( 17.269,  ztamr ) 
     712               zmt2  = SIGN( 21.875,  ztamr ) 
     713               zmt3  = SIGN( 28.200, -ztamr ) 
     714               zes   = 611.0 * EXP(  ABS( ztamr ) * MIN ( zmt1, zmt2 )   & 
     715                  &                / ( ztatm(ji,jj) - 35.86  + MAX( 0.e0, zmt3 ) )  ) 
     716               zev = sf(jp_humi)%fnow(ji,jj,1) * zes                       ! vapour pressure 
     717               zqatm(ji,jj) = 0.622 * zev / ( zpatm(ji,jj) - 0.378 * zev ) ! specific humidity 
     718            ENDDO 
     719         ENDDO 
     720      ELSE 
     721         zqatm(:,:) = sf(jp_humi)%fnow(:,:,1) 
     722      ENDIF 
    543723 
    544724      ! local scalars ( place there for vector optimisation purposes) 
    … …  
    574754               ! Latent Heat 
    575755               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls  * Cice * wndm_ice(ji,jj)   &                            
    576                   &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
     756                  &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - zqatm(ji,jj)  ) ) 
    577757              ! Latent heat sensitivity for ice (Dqla/Dt) 
    578758               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 
    … …  
    659839      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core_flx') 
    660840       
     841      CALL wrk_dealloc( jpi,jpj, zqatm, zpatm, ztatm ) 
    661842   END SUBROUTINE blk_ice_core_flx 
    662843#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2_crs.F90

    r5601 r6772  
    6161   ! 
    6262   PUBLIC   eos_crs        ! called by step, istate, tranpc and zpsgrd modules 
    63    PUBLIC   bn2_crs        ! called by step module 
    6463   PUBLIC   eos_rab_crs    ! called by ldfslp, zdfddm, trabbl 
    6564   PUBLIC   eos_init_crs   ! called by istate module 
    … …  
    392391               DO ji = 1, jpi_crs 
    393392                  ! 
    394                   zh  = gdept_crs(ji,jj,jk) * r1_Z0                                ! depth 
     393                  zh  = fsdept_crs(ji,jj,jk) * r1_Z0                                ! depth 
    395394                  zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    396395                  zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    … …  
    450449                  zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    451450                  zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    452                   zh  = gdept_crs(ji,jj,jk)                 ! depth in meters at t-point 
     451                  zh  = fsdept_crs(ji,jj,jk)                 ! depth in meters at t-point 
    453452                  ztm = tmask_crs(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
    454453                  ! 
    … …  
    689688      ! 
    690689   END SUBROUTINE rab_crs_0d 
    691  
    692  
    693    SUBROUTINE bn2_crs( pts, pab, pn2 ) 
    694       !!---------------------------------------------------------------------- 
    695       !!                  ***  ROUTINE bn2  *** 
    696       !! 
    697       !! ** Purpose :   Compute the local Brunt-Vaisala frequency at the  
    698       !!                time-step of the input arguments 
    699       !! 
    700       !! ** Method  :   pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w 
    701       !!      where alpha and beta are given in pab, and computed on T-points. 
    702       !!      N.B. N^2 is set one for all to zero at jk=1 in istate module. 
    703       !! 
    704       !! ** Action  :   pn2 : square of the brunt-vaisala frequency at w-point  
    705       !! 
    706       !!---------------------------------------------------------------------- 
    707       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celcius,psu] 
    708       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celcius-1,psu-1] 
    709       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
    710       ! 
    711       INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    712       REAL(wp) ::   zaw, zbw, zrw   ! local scalars 
    713       !!---------------------------------------------------------------------- 
    714       ! 
    715       pn2(:,:,:)=0._wp 
    716  
    717       IF( nn_timing == 1 ) CALL timing_start('bn2') 
    718       ! 
    719       DO jk = 2, jpkm1           ! interior points only (2=< jk =< jpkm1 ) 
    720          DO jj = 1, jpj_crs          ! surface and bottom value set to zero one for all in istate.F90 
    721             DO ji = 1, jpi_crs 
    722                !zrw =   ( gdepw_crs(ji,jj,jk  ) - gdept_crs(ji,jj,jk) )   & 
    723                !   &  / ( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) )  
    724                zrw =   gdepw_crs(ji,jj,jk  ) - gdept_crs(ji,jj,jk)     
    725                !?IF( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) .NE. 0._wp )THEN 
    726                IF( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) .LT. 0._wp )THEN 
    727                   zrw = zrw  / ( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) )  
    728                ELSE 
    729                   zrw = 0._wp 
    730                ENDIF 
    731                ! 
    732                zaw = pab(ji,jj,jk,jp_tem) * (1._wp - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw  
    733                zbw = pab(ji,jj,jk,jp_sal) * (1._wp - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 
    734                ! 
    735                IF( e3w_max_crs(ji,jj,jk) .NE. 0._wp ) THEN 
    736                   pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     & 
    737                      &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  & 
    738                   &                    * tmask_crs(ji,jj,jk)  / e3w_max_crs(ji,jj,jk) 
    739                ENDIF 
    740             END DO 
    741          END DO 
    742       END DO 
    743       ! 
    744       IF( nn_timing == 1 )   CALL timing_stop('bn2') 
    745       ! 
    746    END SUBROUTINE bn2_crs 
    747690 
    748691   SUBROUTINE eos_init_crs 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd_crs.F90

    r6101 r6772  
    9191      !!---------------------------------------------------------------------- 
    9292      ! 
     93 
    9394      IF( nn_timing == 1 )  CALL timing_start('tra_adv_tvd') 
    9495      ! 
    … …  
    126127         ! upstream tracer flux in the i and j direction 
    127128         DO jk = 1, jpkm1 
    128             DO jj = 1, jpjm1 
    129                DO ji = 1, fs_jpim1   ! vector opt. 
     129            DO jj = 2, jpj_crs-1 
     130               DO ji = 2, jpi_crs-1 
    130131                  ! upstream scheme 
    131132                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
    … …  
    138139            END DO 
    139140         END DO 
     141         CALL crs_lbc_lnk( zwx, 'U', -1._wp )   
     142         CALL crs_lbc_lnk( zwy, 'V', -1._wp )   
    140143         ! upstream tracer flux in the k direction 
    141144         ! Surface value 
    142145         IF( lk_vvl ) THEN   ;   zwz(:,:, 1 ) = 0.e0                         ! volume variable 
    143          ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) * ptb(:,:,1,jn)   ! linear free surface  
     146         ELSE                ;   zwz(:,:, 1 ) = pwn(:,:,1) !cbr * ptb(:,:,1,jn)   ! linear free surface  
    144147         ENDIF 
    145148         ! Interior value 
    146149         DO jk = 2, jpkm1 
    147             DO jj = 1, jpj 
    148                DO ji = 1, jpi 
     150            DO jj = 2,  jpj_crs-1 
     151               DO ji = nldi_crs, nlei_crs 
    149152                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    150153                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    … …  
    153156            END DO 
    154157         END DO 
     158         CALL crs_lbc_lnk( zwz, 'T', 1. )   
     159 
    155160         ! total advective trend 
    156161         DO jk = 1, jpkm1 
    157162            z2dtt = p2dt(jk) 
    158             DO jj = 2, jpjm1 
    159                DO ji = fs_2, fs_jpim1   ! vector opt. 
     163            DO jj = 2, jpj_crs-1 
     164               DO ji = 2, jpi_crs-1 
    160165                  zbtr = r1_bt_crs(ji,jj,jk)  
    161166                  ! total intermediate advective trends 
    … …  
    163168                     &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    164169                     &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
    165                   ! update and guess with monotonic sheme 
     170 
    166171                  pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra 
    167172                  zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask_crs(ji,jj,jk) 
    … …  
    169174            END DO 
    170175         END DO 
     176  
    171177         !                             ! Lateral boundary conditions on zwi  (unchanged sign) 
    172178         CALL crs_lbc_lnk( zwi, 'T', 1. )   
    … …  
    187193         ! antidiffusive flux on i and j 
    188194         DO jk = 1, jpkm1 
    189             DO jj = 1, jpjm1 
    190                DO ji = 1, fs_jpim1   ! vector opt. 
     195            DO jj = 2, jpj_crs-1 
     196               DO ji = 2, jpi_crs-1 
    191197                  zwx(ji,jj,jk) = 0.5 * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk) 
    192198                  zwy(ji,jj,jk) = 0.5 * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) - zwy(ji,jj,jk) 
    … …  
    198204         ! 
    199205         DO jk = 2, jpkm1          ! Interior value 
    200             DO jj = 1, jpj 
    201                DO ji = 1, jpi 
     206            DO jj = 2, jpj_crs-1 
     207               DO ji = 2, jpi_crs-1 
    202208                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 
    203209               END DO 
    204210            END DO 
    205          END DO 
     211        END DO 
    206212         CALL crs_lbc_lnk( zwx, 'U', -1. )   ;   CALL crs_lbc_lnk( zwy, 'V', -1. )         ! Lateral bondary conditions 
    207213         CALL crs_lbc_lnk( zwz, 'W',  1. ) 
    … …  
    214220         ! ------------------------------------ 
    215221         DO jk = 1, jpkm1 
    216             DO jj = 2, jpjm1 
    217                DO ji = fs_2, fs_jpim1   ! vector opt.   
     222            DO jj = 2, jpj_crs-1 
     223               DO ji = 2, jpi_crs-1 
    218224                  zbtr = r1_bt_crs(ji,jj,jk) 
    219225                  ! total advective trends 
    … …  
    247253      END DO 
    248254      ! 
     255 
    249256                   CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz , zwx, zwy ) 
    250257      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
    … …  
    302309         ikm1 = MAX(jk-1,1) 
    303310         z2dtt = p2dt(jk) 
    304          DO jj = 2, jpjm1 
    305             DO ji = fs_2, fs_jpim1   ! vector opt. 
     311         DO jj = 2, jpj_crs-1 
     312            DO ji = 2, jpi_crs-1 
    306313 
    307314               ! search maximum in neighbourhood 
    … …  
    339346      ! ---------------------------------------- 
    340347      DO jk = 1, jpkm1 
    341          DO jj = 2, jpjm1 
    342             DO ji = fs_2, fs_jpim1   ! vector opt. 
     348         DO jj = 2, jpj_crs-1 
     349            DO ji = 2, jpi_crs-1 
    343350               zau = MIN( 1.e0, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    344351               zbu = MIN( 1.e0, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_crs.F90

    r6101 r6772  
    1010   !!            3.3  !  2010-09  (C. Ethe, G. Madec) Merge TRA-TRC 
    1111   !!---------------------------------------------------------------------- 
    12 #if   defined key_ldfslp   ||   defined key_esopa 
     12#if   ( defined key_ldfslp   ||   defined key_esopa ) && defined key_crs 
    1313   !!---------------------------------------------------------------------- 
    1414   !!   'key_ldfslp'               slope of the lateral diffusive direction 
    … …  
    1919   !!                  the isopycnal or geopotential s-coord. operator  
    2020   !!---------------------------------------------------------------------- 
    21 !   USE oce             ! ocean dynamics and active tracers 
    22 !   USE dom_oce         ! ocean space and time domain 
    23 !   USE trc_oce         ! share passive tracers/Ocean variables 
    24 !   USE zdf_oce         ! ocean vertical physics 
    25 !   USE ldftra_oce      ! ocean active tracers: lateral physics 
    26 !   USE ldfslp          ! iso-neutral slopes 
    2721   USE ldfslp_crs          ! iso-neutral slopes 
    2822   USE diaptr          ! poleward transport diagnostics 
    … …  
    3529   USE wrk_nemo        ! Memory Allocation 
    3630   USE timing          ! Timing 
    37 !   USE crs 
    3831   USE oce_trc 
    3932   USE iom, ONLY : iom_put,iom_swap 
    … …  
    113106      REAL(wp)                         ::   zztmp               ! local scalar 
    114107#endif 
     108      REAL(wp)                         ::   zmin,zmax 
    115109      REAL(wp), POINTER, DIMENSION(:,:  ) ::  zdkt, zdk1t, z2d 
    116110      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdit, zdjt, ztfw , zftu,  zftv  
    … …  
    188182                     &             + tmask_crs(ji,jj+1,jk+1) + tmask_crs(ji,jj,jk  ), 1. ) 
    189183                  ! 
    190                   zcof1 = - fsahtu(ji,jj,jk) * e2e3u_msk(ji,jj,jk) * uslp_crs(ji,jj,jk) * zmsku / MAX( 1._wp , e3u_max_crs(ji,jj,jk)) 
    191                   zcof2 = - fsahtv(ji,jj,jk) * e1e3v_msk(ji,jj,jk) * vslp_crs(ji,jj,jk) * zmskv / MAX( 1._wp , e3v_max_crs(ji,jj,jk)) 
     184                  zcof1 = - fsahtu(ji,jj,jk) * e2e3u_msk(ji,jj,jk) * uslp_crs(ji,jj,jk) * zmsku / MAX( 1._wp , fse3u_max_crs(ji,jj,jk)) 
     185                  zcof2 = - fsahtv(ji,jj,jk) * e1e3v_msk(ji,jj,jk) * vslp_crs(ji,jj,jk) * zmskv / MAX( 1._wp , fse3v_max_crs(ji,jj,jk)) 
    192186                  ! 
    193187                  zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk)   & 
    … …  
    199193               END DO 
    200194            END DO 
    201             CALL iom_swap( "nemo_crs"  ) 
    202             CALL iom_put( "zftu" , zftu ) 
    203             CALL iom_put( "zftv" , zftv ) 
    204             CALL iom_swap( "nemo" ) 
    205195 
    206196            ! II.4 Second derivative (divergence) and add to the general trend 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap_crs.F90

    r6101 r6772  
    124124                     ikv = mbkv_crs(ji,jj) 
    125125                     IF( iku == jk ) THEN 
    126                         zabe1 = fsahtu(ji,jj,iku) * umask_crs(ji,jj,iku) * e1ur(ji,jj) * e3u_crs(ji,jj,iku) 
     126                        zabe1 = fsahtu(ji,jj,iku) * umask_crs(ji,jj,iku) * e1ur(ji,jj) * fse3u_crs(ji,jj,iku) 
    127127                        ztu(ji,jj,jk) = zabe1 * pgu(ji,jj,jn) 
    128128                     ENDIF 
    129129                     IF( ikv == jk ) THEN 
    130                         zabe2 = fsahtv(ji,jj,ikv) * vmask_crs(ji,jj,ikv) * e2vr(ji,jj) * e3v_crs(ji,jj,ikv) 
     130                        zabe2 = fsahtv(ji,jj,ikv) * vmask_crs(ji,jj,ikv) * e2vr(ji,jj) * fse3v_crs(ji,jj,ikv) 
    131131                        ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 
    132132                     ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r5602 r6772  
    4949   USE agrif_opa_interp 
    5050#endif 
     51   USE crs 
    5152 
    5253   IMPLICIT NONE 
    … …  
    5657   PUBLIC   tra_nxt_fix   ! to be used in trcnxt 
    5758   PUBLIC   tra_nxt_vvl   ! to be used in trcnxt 
     59   PUBLIC   tra_nxt_vvl_crs ! to be used in trcnxt 
    5860 
    5961   REAL(wp) ::   rbcp   ! Brown & Campana parameters for semi-implicit hpg 
    … …  
    349351   END SUBROUTINE tra_nxt_vvl 
    350352 
     353  SUBROUTINE tra_nxt_vvl_crs( kt, kit000, p2dt, cdtype, ptb, ptn, pta, psbc_tc, psbc_tc_b, kjpt ) 
     354      !!---------------------------------------------------------------------- 
     355      !!                   ***  ROUTINE tra_nxt_vvl  *** 
     356      !! 
     357      !! ** Purpose :   Time varying volume: apply the Asselin time filter   
     358      !!                and swap the tracer fields. 
     359      !!  
     360      !! ** Method  : - Apply a thickness weighted Asselin time filter on now fields. 
     361      !!              - save in (ta,sa) a thickness weighted average over the three  
     362      !!             time levels which will be used to compute rdn and thus the semi- 
     363      !!             implicit hydrostatic pressure gradient (ln_dynhpg_imp = T) 
     364      !!              - swap tracer fields to prepare the next time_step. 
     365      !!                This can be summurized for tempearture as: 
     366      !!             ztm = ( e3t_n*tn + rbcp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] )   ln_dynhpg_imp = T 
     367      !!                  /( e3t_n    + rbcp*[ e3t_b    - 2 e3t_n    + e3t_a    ] )    
     368      !!             ztm = 0                                                       otherwise 
     369      !!             tb  = ( e3t_n*tn + atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) 
     370      !!                  /( e3t_n    + atfp*[ e3t_b    - 2 e3t_n    + e3t_a    ] ) 
     371      !!             tn  = ta  
     372      !!             ta  = zt        (NB: reset to 0 after eos_bn2 call) 
     373      !! 
     374      !! ** Action  : - (tb,sb) and (tn,sn) ready for the next time step 
     375      !!              - (ta,sa) time averaged (t,s)   (ln_dynhpg_imp = T) 
     376      !!---------------------------------------------------------------------- 
     377      INTEGER         , INTENT(in   )                               ::  kt       ! ocean time-step index 
     378      INTEGER         , INTENT(in   )                               ::  kit000   ! first time step index 
     379      REAL(wp)        , INTENT(in   ), DIMENSION(jpk)               ::  p2dt     ! time-step 
     380      CHARACTER(len=3), INTENT(in   )                               ::  cdtype   ! =TRA or TRC (tracer indicator) 
     381      INTEGER         , INTENT(in   )                               ::  kjpt     ! number of tracers 
     382      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptb      ! before tracer fields 
     383      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  ptn      ! now tracer fields 
     384      REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::  pta      ! tracer trend 
     385      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc   ! surface tracer content 
     386      REAL(wp)        , INTENT(in   ), DIMENSION(jpi,jpj,kjpt)      ::  psbc_tc_b ! before surface tracer content 
     387 
     388      !!      
     389      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
     390      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
     391      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
     392      REAL(wp) ::   zfact2, ze3t_b, ze3t_n, ze3t_a, ze3t_f, ze3t_d   !   -      - 
     393      !!---------------------------------------------------------------------- 
     394      !!---------------------------------------------------------------------- 
     395      ! 
     396      IF( kt == kit000 )  THEN 
     397         IF(lwp) WRITE(numout,*) 
     398         IF(lwp) WRITE(numout,*) 'tra_nxt_vvl : time stepping', cdtype 
     399         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     400      ENDIF 
     401      ! 
     402      IF( cdtype == 'TRA' )  THEN 
     403         ll_tra_hpg = ln_dynhpg_imp    ! active  tracers case  and  semi-implicit hpg 
     404         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
     405         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
     406      ELSE 
     407         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
     408         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
     409         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
     410      ENDIF 
     411      ! 
     412      DO jn = 1, kjpt 
     413         DO jk = 1, jpkm1 
     414            zfact1 = atfp * p2dt(jk) 
     415            zfact2 = zfact1 / rau0 
     416            DO jj = 1, jpj 
     417               DO ji = 1, jpi 
     418                  ze3t_b = fse3t_b_crs(ji,jj,jk) 
     419                  ze3t_n = fse3t_n_crs(ji,jj,jk) 
     420                  ze3t_a = fse3t_a_crs(ji,jj,jk) 
     421                  !                                         ! tracer content at Before, now and after 
     422                  ztc_b  = ptb(ji,jj,jk,jn) * ze3t_b 
     423                  ztc_n  = ptn(ji,jj,jk,jn) * ze3t_n 
     424                  ztc_a  = pta(ji,jj,jk,jn) * ze3t_a 
     425                  ! 
     426                  ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b 
     427                  ztc_d  = ztc_a  - 2. * ztc_n  + ztc_b 
     428                  ! 
     429                  ze3t_f = ze3t_n + atfp * ze3t_d 
     430                  ztc_f  = ztc_n  + atfp * ztc_d 
     431                  ! 
     432                  IF( jk == 1 ) THEN           ! first level  
     433                     ze3t_f = ze3t_f - zfact2 * ( emp_b_crs(ji,jj) - emp_crs(ji,jj) + rnf_crs(ji,jj) - rnf_b_crs(ji,jj) ) 
     434                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
     435                  ENDIF 
     436!cbr as it is a subroutine dedicated to crs, TRA options are not necessary 
     437!cbr                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
     438!cbr                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) ) 
     439!cbr 
     440!cbr                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &                  ! river runoffs 
     441!cbr                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) & 
     442!cbr                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     443 
     444                  ze3t_f = 1.e0 / ze3t_f 
     445                  ptb(ji,jj,jk,jn) = ztc_f * ze3t_f       ! ptb <-- ptn filtered 
     446                  ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn)     ! ptn <-- pta 
     447                  ! 
     448                  IF( ll_tra_hpg ) THEN        ! semi-implicit hpg (T & S only) 
     449                     ze3t_d           = 1.e0   / ( ze3t_n + rbcp * ze3t_d ) 
     450                     pta(ji,jj,jk,jn) = ze3t_d * ( ztc_n  + rbcp * ztc_d  )   ! ta <-- Brown & Campana average 
     451                  ENDIF 
     452               END DO 
     453            END DO 
     454         END DO 
     455         !  
     456      END DO 
     457      ! 
     458   END SUBROUTINE tra_nxt_vvl_crs 
     459 
     460 
    351461   !!====================================================================== 
    352462END MODULE tranxt 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp_crs.F90

    r5601 r6772  
    7878      !! ** Action  : - pta  becomes the after tracer 
    7979      !!--------------------------------------------------------------------- 
     80      USE ieee_arithmetic 
    8081      ! 
    8182      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
    … …  
    9091      REAL(wp) ::  zrhs, ze3tb, ze3tn, ze3ta   ! local scalars 
    9192      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwi, zwt,zwd,zws 
     93      REAL(wp) ::  zmin,zmax 
    9294      !!--------------------------------------------------------------------- 
    9395      ! 
    … …  
    135137               END DO 
    136138            ELSE IF( l_traldf_rot ) THEN     ! standard isoneutral diff 
    137                DO jk = 2, jpkm1 
    138                   DO jj = 2, jpjm1 
    139                      DO ji = fs_2, fs_jpim1   ! vector opt. 
     139              DO jk = 2, jpkm1 
     140                  DO jj = 2, jpj_crs-1 
     141                     DO ji = 2, jpi_crs-1 
    140142                        zwt(ji,jj,jk) = zwt(ji,jj,jk) + fsahtw(ji,jj,jk)                       & 
    141143                           &                          * (  wslpi_crs(ji,jj,jk) * wslpi_crs(ji,jj,jk)   & 
    … …  
    148150#endif 
    149151            DO jk = 1, jpkm1 
    150                DO jj = 2, jpjm1 
    151                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    152                      ze3ta =  ( 1. - r_vvl ) +        r_vvl   * e3t_crs(ji,jj,jk)   ! after scale factor at T-point 
    153                      ze3tn =         r_vvl   + ( 1. - r_vvl ) * e3t_crs(ji,jj,jk)   ! now   scale factor at T-point 
     152               DO jj = 2, jpj_crs-1 
     153                  DO ji = 2, jpi_crs-1 
     154 
     155#if defined key_vvl 
     156                     ze3ta =  ( 1. - r_vvl ) +        r_vvl   * fse3t_a_crs(ji,jj,jk)   ! after scale factor at T-point 
     157                     ze3tn =         r_vvl   + ( 1. - r_vvl ) * fse3t_n_crs(ji,jj,jk)   ! now   scale factor at T-point 
     158#else 
     159                     ze3ta =  ( 1. - r_vvl ) +        r_vvl   * e3t_0_crs(ji,jj,jk)   ! after scale factor at T-point 
     160                     ze3tn =         r_vvl   + ( 1. - r_vvl ) * e3t_0_crs(ji,jj,jk)   ! now   scale factor at T-point 
     161#endif 
    154162                     !cbr zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * e3w_1d(jk  ) )  !cc 
    155163                     !cbr zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * e3w_1d(jk+1) )  !cc 
    156                      zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * e3w_max_crs(ji,jj,jk) ) 
    157                      zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * e3w_max_crs(ji,jj,jk+1) ) 
     164                     zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * fse3w_max_crs(ji,jj,jk) ) 
     165                     zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w_max_crs(ji,jj,jk+1) ) 
    158166                     zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 
    159167                 END DO 
    … …  
    182190            ! first recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    183191            ! done once for all passive tracers (so included in the IF instruction) 
    184             DO jj = 2, jpjm1 
    185                DO ji = fs_2, fs_jpim1 
     192            DO jj = 2, jpj_crs-1 
     193               DO ji = 2, jpi_crs-1 
    186194                  zwt(ji,jj,1) = zwd(ji,jj,1) 
    187195               END DO 
    188196            END DO 
    189197            DO jk = 2, jpkm1 
    190                DO jj = 2, jpjm1 
    191                   DO ji = fs_2, fs_jpim1 
     198               DO jj = 2, jpj_crs-1 
     199                  DO ji = 2, jpi_crs-1 
    192200                    zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
    193201                  END DO 
    … …  
    198206         !     
    199207         ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    200          DO jj = 2, jpjm1 
    201             DO ji = fs_2, fs_jpim1 
    202                ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,1) 
    203                ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,1) 
     208         DO jj = 2, jpj_crs-1 
     209            DO ji = 2, jpi_crs-1 
     210#if defined key_vvl 
     211               ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b_crs(ji,jj,1) 
     212               ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t_n_crs(ji,jj,1) 
     213#else 
     214               ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_0_crs(ji,jj,1) 
     215               ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_0_crs(ji,jj,1) 
     216#endif 
    204217               pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn) + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 
    205218            END DO 
    … …  
    207220 
    208221         DO jk = 2, jpkm1 
    209             DO jj = 2, jpjm1 
    210                DO ji = fs_2, fs_jpim1 
    211                   ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,jk) 
    212                   ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,jk) 
     222            DO jj = 2, jpj_crs-1 
     223               DO ji = 2, jpi_crs-1 
     224#if defined key_vvl 
     225                  ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b_crs(ji,jj,jk) 
     226                  ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t_n_crs(ji,jj,jk) 
     227#else 
     228                  ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_0_crs(ji,jj,jk) 
     229                  ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_0_crs(ji,jj,jk) 
     230#endif 
    213231                  zrhs = ze3tb * ptb(ji,jj,jk,jn) + p2dt(jk) * ze3tn * pta(ji,jj,jk,jn)   ! zrhs=right hand side  
    214                   pta(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn) 
    215                  
     232                  pta(ji,jj,jk,jn) = zrhs  - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn) 
    216233               END DO 
    217234            END DO 
    … …  
    219236 
    220237         ! third recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer) 
    221          DO jj = 2, jpjm1 
    222             DO ji = fs_2, fs_jpim1 
     238         DO jj = 2, jpj_crs-1 
     239            DO ji = 2, jpi_crs-1 
    223240               pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask_crs(ji,jj,jpkm1) 
    224241            END DO 
    225242         END DO 
    226243         DO jk = jpk-2, 1, -1 
    227             DO jj = 2, jpjm1 
    228                DO ji = fs_2, fs_jpim1 
     244            DO jj = 2, jpj_crs-1 
     245               DO ji = 2, jpi_crs-1 
    229246                  pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) )   & 
    230                      &             / zwt(ji,jj,jk) * tmask_crs(ji,jj,jk) 
    231                   
    232                END DO 
    233             END DO 
    234          END DO 
    235  
     247                    &             / zwt(ji,jj,jk) * tmask_crs(ji,jj,jk) 
     248              END DO 
     249            END DO 
     250         END DO 
    236251         !                                            ! ================= ! 
    237252      END DO                                          !  end tracer loop  ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde_crs.F90

    r5601 r6772  
    9696      INTEGER  ::   iku, ikv, ikum1, ikvm1   ! partial step level (ocean bottom level) at u- and v-points 
    9797      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv  ! temporary scalars 
    98   !cc    REAL(wp), POINTER, DIMENSION(:,:  ) ::  zri, zrj, zhi, zhj 
    99   !cc    REAL(wp), POINTER, DIMENSION(:,:,:) ::  zti, zte    ! interpolated value of tracer 
    10098      REAL(wp), ALLOCATABLE, DIMENSION(:,:  ) ::  zri, zrj, zhi, zhj 
    10199      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  zti, zte    ! interpolated value of tracer 
    … …  
    105103      IF( nn_timing == 1 )  CALL timing_start( 'zps_hde_crs') 
    106104      ! 
    107 !!      CALL wrk_alloc( jpi, jpj,       zri, zrj, zhi, zhj )  
    108 !!      CALL wrk_alloc( jpi, jpj, kjpt, zti, zte           )  
    109105      ALLOCATE( zri(jpi_crs,jpj_crs) , zrj(jpi_crs,jpj_crs), zte(jpi_crs ,jpj_crs ,kjpt), & 
    110106         &      zhi(jpi_crs,jpj_crs) , zhj(jpi_crs,jpj_crs), zti(jpi_crs ,jpj_crs ,kjpt)) 
    … …  
    112108      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    113109         ! 
    114 # if defined key_vectopt_loop 
    115          jj = 1 
    116          DO ji = 1, jpij-jpi   ! vector opt. (forced unrolled) 
    117 # else 
    118110         DO jj = 1, jpjm1 
    119111            DO ji = 1, jpim1 
    120 # endif 
     112 
    121113               iku = mbku_crs(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    122114               ikv = mbkv_crs(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    123           !     ze3wu = e3w_crs(ji+1,jj  ,iku) - e3w_crs(ji,jj,iku) 
    124           !     ze3wv = e3w_crs(ji  ,jj+1,ikv) - e3w_crs(ji,jj,ikv) 
    125                ze3wu = e3w_max_crs(ji+1,jj  ,iku) - e3w_max_crs(ji,jj,iku) 
    126                ze3wv = e3w_max_crs(ji  ,jj+1,ikv) - e3w_max_crs(ji,jj,ikv) 
     115               ze3wu = e3w_max_0_crs(ji+1,jj  ,iku) - e3w_max_0_crs(ji,jj,iku) 
     116               ze3wv = e3w_max_0_crs(ji  ,jj+1,ikv) - e3w_max_0_crs(ji,jj,ikv) 
    127117               ! 
    128118               ! i- direction 
    129119               IF( ze3wu >= 0._wp ) THEN      ! case 1 
    130                   zmaxu =  ze3wu / e3w_max_crs(ji+1,jj,iku)   
    131                  !    zmaxu =  ze3wu / e3w_crs(ji+1,jj,iku) 
     120#if defined key_vvl 
     121                  zmaxu =  ze3wu / e3w_max_n_crs(ji+1,jj,iku)   
     122#else 
     123                  zmaxu =  ze3wu / e3w_max_0_crs(ji+1,jj,iku)   
     124#endif 
    132125                  ! interpolated values of tracers 
    133126                  zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    … …  
    135128                  pgtu(ji,jj,jn) = umask_crs(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    136129               ELSE                           ! case 2 
    137                   zmaxu = -ze3wu / e3w_max_crs(ji,jj,iku) 
    138                  !    zmaxu = -ze3wu / e3w_crs(ji,jj,iku) 
     130#if defined key_vvl 
     131                  zmaxu = -ze3wu / e3w_max_n_crs(ji,jj,iku) 
     132#else 
     133                  zmaxu = -ze3wu / e3w_max_0_crs(ji,jj,iku) 
     134#endif 
    139135                  ! interpolated values of tracers 
    140136                  zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    … …  
    145141               ! j- direction 
    146142               IF( ze3wv >= 0._wp ) THEN      ! case 1 
    147                   zmaxv =  ze3wv / e3w_max_crs(ji,jj+1,ikv) 
    148                !      zmaxv =  ze3wv / e3w_crs(ji,jj+1,ikv) 
     143#if defined key_vvl 
     144                  zmaxv =  ze3wv / e3w_max_n_crs(ji,jj+1,ikv) 
     145#else 
     146                  zmaxv =  ze3wv / e3w_max_0_crs(ji,jj+1,ikv) 
     147#endif 
    149148                  ! interpolated values of tracers 
    150149                  zte(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    … …  
    152151                  pgtv(ji,jj,jn) = vmask_crs(ji,jj,1) * ( zte(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    153152               ELSE                           ! case 2 
    154                   zmaxv =  -ze3wv / e3w_max_crs(ji,jj,ikv) 
    155                 !     zmaxv = -ze3wv / e3w_crs(ji,jj,ikv) 
     153#if defined key_vvl 
     154                  zmaxv =  -ze3wv / e3w_max_n_crs(ji,jj,ikv) 
     155#else 
     156                  zmaxv =  -ze3wv / e3w_max_0_crs(ji,jj,ikv) 
     157#endif 
    156158                  ! interpolated values of tracers 
    157159                  zte(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    … …  
    160162               ENDIF 
    161163 
    162 # if ! defined key_vectopt_loop 
    163164            END DO 
    164 # endif 
    165165         END DO 
    166166         CALL crs_lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL crs_lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    167167         ! 
    168168      END DO 
    169 !WRITE(numout,*) ' test24 ', e3w_max_crs 
     169 
    170170      ! horizontal derivative of density anomalies (rd) 
    171171      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
    172 # if defined key_vectopt_loop 
    173          jj = 1 
    174          DO ji = 1, jpij-jpi   ! vector opt. (forced unrolled) 
    175 # else 
    176172         DO jj = 1, jpjm1 
    177173            DO ji = 1, jpim1 
    178 # endif 
     174 
    179175               iku = mbku_crs(ji,jj) 
    180176               ikv = mbkv_crs(ji,jj) 
    181    !cc             ze3wu  = e3w_max_crs(ji+1,jj  ,iku) - e3w_max_crs(ji,jj,iku)   !gradiant horizontal pas de max 
    182                ze3wu  = e3w_crs(ji+1,jj  ,iku) - e3w_crs(ji,jj,iku) 
    183        !cc        ze3wv  = e3w_max_crs(ji  ,jj+1,ikv) - e3w_max_crs(ji,jj,ikv) 
    184                ze3wv  = e3w_crs(ji  ,jj+1,ikv) - e3w_crs(ji,jj,ikv) 
    185                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_crs(ji  ,jj,iku)     ! i-direction: case 1 
    186                ELSE                        ;   zhi(ji,jj) = gdept_crs(ji+1,jj,iku)     ! -     -      case 2 
    187                ENDIF 
    188                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_crs(ji,jj  ,ikv)     ! j-direction: case 1 
    189                ELSE                        ;   zhj(ji,jj) = gdept_crs(ji,jj+1,ikv)     ! -     -      case 2 
    190                ENDIF 
    191 # if ! defined key_vectopt_loop 
     177               ze3wu  = e3w_0_crs(ji+1,jj  ,iku) - e3w_0_crs(ji,jj,iku) 
     178               ze3wv  = e3w_0_crs(ji  ,jj+1,ikv) - e3w_0_crs(ji,jj,ikv) 
     179               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = fsdept_crs(ji  ,jj,iku)     ! i-direction: case 1 
     180               ELSE                        ;   zhi(ji,jj) = fsdept_crs(ji+1,jj,iku)     ! -     -      case 2 
     181               ENDIF 
     182               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = fsdept_crs(ji,jj  ,ikv)     ! j-direction: case 1 
     183               ELSE                        ;   zhj(ji,jj) = fsdept_crs(ji,jj+1,ikv)     ! -     -      case 2 
     184               ENDIF 
     185 
    192186            END DO 
    193 # endif 
    194187         END DO 
    195188         CALL eos_crs( zti, zhi, zri )   
    196189         CALL eos_crs( zte, zhj, zrj ) 
     190 
    197191         ! Gradient of density at the last level  
    198 # if defined key_vectopt_loop 
    199          jj = 1 
    200          DO ji = 1, jpij-jpi   ! vector opt. (forced unrolled) 
    201 # else 
    202192         DO jj = 1, jpjm1 
    203193            DO ji = 1, jpim1 
    204 # endif 
    205194               iku = mbku_crs(ji,jj) 
    206195               ikv = mbkv_crs(ji,jj) 
    207       !         ze3wu  = e3w_max_crs(ji+1,jj  ,iku) - e3w_max_crs(ji,jj,iku)         gradient horizontal 
    208                 ze3wu  = e3w_crs(ji+1,jj  ,iku) - e3w_crs(ji,jj,iku) 
    209       !         ze3wv  = e3w_max_crs(ji  ,jj+1,ikv) - e3w_max_crs(ji,jj,ikv)         gradient horizontal 
    210                 ze3wv  = e3w_crs(ji  ,jj+1,ikv) - e3w_crs(ji,jj,ikv) 
     196                ze3wu  = e3w_0_crs(ji+1,jj  ,iku) - e3w_0_crs(ji,jj,iku) 
     197                ze3wv  = e3w_0_crs(ji  ,jj+1,ikv) - e3w_0_crs(ji,jj,ikv) 
    211198               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask_crs(ji,jj,1) * ( zri(ji  ,jj) - prd(ji,jj,iku) )   ! i: 1 
    212199               ELSE                        ;   pgru(ji,jj) = umask_crs(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj) )   ! i: 2 
    … …  
    215202               ELSE                        ;   pgrv(ji,jj) = vmask_crs(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )   ! j: 2 
    216203               ENDIF 
    217 # if ! defined key_vectopt_loop 
     204 
    218205            END DO 
    219 # endif 
    220206         END DO 
    221  
    222207 
    223208         CALL crs_lbc_lnk( pgru , 'U', -1. )   ;   CALL crs_lbc_lnk( pgrv , 'V', -1. )   ! Lateral boundary conditions 
    … …  
    225210      END IF 
    226211      ! 
    227       !!ccCALL wrk_dealloc( jpi, jpj,       zri, zrj, zhi, zhj )  
    228       !!ccCALL wrk_dealloc( jpi, jpj, kjpt, zti, zte           )  
    229212      DEALLOCATE( zri , zrj, zte, zhi, zhj, zti) 
    230213      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl_crs.F90

    r6101 r6772  
    2424   USE trc_oce, ONLY : lk_offline ! offline flag 
    2525   USE crs 
     26   USE ieee_arithmetic 
    2627 
    2728   IMPLICIT NONE 
    … …  
    6465      REAL(wp) ::   zN2_c        ! local scalar 
    6566      INTEGER, POINTER, DIMENSION(:,:) ::   imld   ! 2D workspace 
    66       REAL(wp), POINTER, DIMENSION(:,:) ::  z2d   ! 2D workspace 
    6767      !!---------------------------------------------------------------------- 
    6868      ! 
    … …  
    7070      ! 
    7171      CALL wrk_alloc( jpi_crs,jpj_crs, imld ) 
    72       CALL wrk_alloc( jpi_crs,jpj_crs, z2d ) 
    7372 
    7473      IF( kt == nit000 ) THEN 
    … …  
    9594            iiki = imld(ji,jj) 
    9695            iikn = nmln_crs(ji,jj) 
    97             IF( iiki .NE. 0 ) hmld_crs (ji,jj) = ( gdepw_crs(ji,jj,iiki  ) - gdepw_crs(ji,jj,1 )            )   * tmask_crs(ji,jj,1)  ! Turbocline depth  
    98             IF( iiki .NE. 0 ) hmlpt_crs(ji,jj) = ( gdept_crs(ji,jj,iikn-1) - gdepw_crs(ji,jj,1 )            )   * tmask_crs(ji,jj,1)  ! depth of the last T-point inside the mixed layer 
     96            hmld_crs (ji,jj) = ( fsdepw_crs(ji,jj,iiki  ) - fsdepw_crs(ji,jj,1    )  ) * tmask_crs(ji,jj,1)    ! Turbocline depth  
     97            hmlp_crs (ji,jj) = ( fsdepw_crs(ji,jj,iikn  ) - fsdepw_crs(ji,jj,nla10)  ) * tmask_crs(ji,jj,1)    ! Mixed layer depth 
     98            hmlpt_crs(ji,jj) = ( fsdept_crs(ji,jj,iikn-1) - fsdepw_crs(ji,jj,1    )  ) * tmask_crs(ji,jj,1)    ! depth of the last T-point inside the mixed layer 
    9999         END DO 
    100100      END DO 
    101101      ! 
    102       z2d=REAL(nmln_crs,wp) 
    103       CALL iom_put("nmln_crs",z2d) 
    104       CALL iom_put("hmlpt_crs",hmlpt_crs) 
    105       ! 
    106102      CALL wrk_dealloc( jpi_crs,jpj_crs, imld ) 
    107       CALL wrk_dealloc( jpi_crs,jpj_crs, z2d ) 
    108103      ! 
    109104      IF( nn_timing == 1 )  CALL timing_stop('zdf_mxl_crs') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke_crs.F90

    r6101 r6772  
    260260            DO ji = 2, jpi_crs-1   ! vector opt. 
    261261               DO jk = 2, jpkm1         ! from the surface to the bottom : lup 
    262                   zmxld_crs(ji,jj,jk) = MIN( zmxld_crs(ji,jj,jk-1) + e3t_crs(ji,jj,jk-1), zmxlm_crs(ji,jj,jk) ) 
     262                  zmxld_crs(ji,jj,jk) = MIN( zmxld_crs(ji,jj,jk-1) + fse3t_crs(ji,jj,jk-1), zmxlm_crs(ji,jj,jk) ) 
    263263               END DO 
    264264               DO jk = jpkm1, 2 , -1     ! from the bottom to the surface : ldown 
    265                   zmxlm_crs(ji,jj,jk) = MIN( zmxlm_crs(ji,jj,jk+1) + e3t_crs(ji,jj,jk+1), zmxlm_crs(ji,jj,jk) ) 
     265                  zmxlm_crs(ji,jj,jk) = MIN( zmxlm_crs(ji,jj,jk+1) + fse3t_crs(ji,jj,jk+1), zmxlm_crs(ji,jj,jk) ) 
    266266               END DO 
    267267            END DO 
    … …  
    312312            DO ji = 2, jpi_crs-1   ! vector opt. 
    313313               DO jk = 2, jpkm1 
    314                   zcoef = avm_crs(ji,jj,jk) * 2._wp * e3w_crs(ji,jj,jk) * e3w_crs(ji,jj,jk) 
     314                  zcoef = avm_crs(ji,jj,jk) * 2._wp * fse3w_crs(ji,jj,jk) * fse3w_crs(ji,jj,jk) 
    315315                  !                                          ! shear 
    316316                  zdku = avmu_crs(ji-1,jj,jk) * ( un_crs(ji-1,jj,jk-1) - un_crs(ji-1,jj,jk) ) * ( ub_crs(ji-1,jj,jk-1) - ub_crs(ji-1,jj,jk) )   & 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r5602 r6772  
    5656   USE ldfdyn          ! lateral viscosity setting      (ldfdyn_init routine) 
    5757   USE ldftra          ! lateral diffusivity setting    (ldftra_init routine) 
     58   USE ldftra_crs      ! lateral diffusivity setting    (ldftra_init routine) 
    5859   USE zdfini          ! vertical physics setting          (zdf_init routine) 
    5960   USE phycst          ! physical constant                  (par_cst routine) 
    … …  
    118119      !!---------------------------------------------------------------------- 
    119120      INTEGER ::   istp       ! time step index 
    120       CHARACTER(len=20) :: cmd  
     121      CHARACTER(len=30) :: cmd  
    121122      !!---------------------------------------------------------------------- 
    122123      ! 
    … …  
    183184      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA 
    184185      ! 
    185       IF( nstop /= 0 .AND. lwp ) THEN   ! error print 
     186      IF( nstop /= 0 ) THEN   ! error print 
     187         cmd='touch nemo_NOK' 
     188         CALL system(cmd) 
    186189         WRITE(numout,cform_err) 
    187190         WRITE(numout,*) nstop, ' error have been found' 
     191      ELSE 
     192         cmd='touch nemo_OK' 
     193         CALL system(cmd) 
    188194      ENDIF 
    189195      ! 
    … …  
    460466      IF( ln_crs_top )      CALL dom_grid_crs 
    461467                            CALL     trc_init 
     468                            CALL ldf_tra_crs_init 
    462469      IF( ln_crs_top )      CALL dom_grid_glo 
    463470#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step.F90

    r6101 r6772  
    257257                         CALL dom_grid_crs 
    258258 
    259                          !CALL eos_rab_crs( tsn_crs, rab_crs_n )       ! now    local thermal/haline expension ratio at T-points 
    260                          !CALL bn2_crs    ( tsn_crs, rab_crs_n, rb2_crs  ) ! now    Brunt-Vaisala frequency 
    261                          CALL eos_crs ( tsn_crs, rhd_crs, rhop_crs, gdept_crs(:,:,:) ) ! now in situ density for hpg computation 
     259                         CALL zdf_mxl_crs(kstp) 
     260                         CALL eos_crs ( tsn_crs, rhd_crs, rhop_crs, fsdept_crs(:,:,:) ) ! now in situ density for hpg computation 
    262261                         CALL iom_put("rhop_crs",rhop_crs) 
    263262                         CALL iom_put("rhd_crs",rhd_crs) 
    … …  
    270269 
    271270      ENDIF 
    272                          CALL zdf_mxl_crs(kstp) 
    273271 
    274272      IF( ln_crs_top )   CALL dom_grid_crs 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r5602 r6772  
    9898   USE floats           ! floats computation               (flo_stp routine) 
    9999 
     100   USE crs 
    100101   USE crsfld           ! Standard output on coarse grid   (crs_fld routine) 
    101102   USE zdfmxl_crs 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcini_my_trc.F90

    r5602 r6772  
    5858 
    5959       
    60       IF( .NOT. ln_rsttr ) trb(:,:,:,jp_myt0:jp_myt1) = 0. 
    61       IF( .NOT. ln_rsttr ) trn(:,:,:,jp_myt0:jp_myt1) = 0. 
     60      IF( .NOT. ln_rsttr ) trb(:,:,:,jp_myt0:jp_myt1) = 0._wp 
     61      IF( .NOT. ln_rsttr ) trn(:,:,:,jp_myt0:jp_myt1) = 0._wp 
    6262      ! 
    6363   END SUBROUTINE trc_ini_my_trc 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcwri_my_trc.F90

    r5602 r6772  
    1616   USE crs, ONLY : ln_crs,ln_crs_top,ahtt_crs,ahtu_crs,ahtv_crs,ahtw_crs,jpi_crs,jpj_crs 
    1717   USE iom, ONLY : iom_swap, iom_put 
     18   USE ieee_arithmetic 
    1819 
    1920   IMPLICIT NONE 
    … …  
    3637      IF( ln_crs_top ) CALL iom_swap( "nemo_crs" ) 
    3738 
    38       CALL iom_put("ahtt_crs",ahtt_crs) 
    39       CALL iom_put("ahtu_crs",ahtu_crs) 
    40       CALL iom_put("ahtv_crs",ahtv_crs) 
    41       CALL iom_put("ahtw_crs",ahtw_crs) 
    42  
    43   
    4439      ! write the tracer concentrations in the file 
    4540      ! --------------------------------------- 
     41      WHERE(ieee_is_nan(trn))trn=1.e30 
    4642      DO jn = jp_myt0, jp_myt1 
    4743         cltra = TRIM( ctrcnm(jn) )                  ! short title for tracer 
    48          IF( lk_vvl ) THEN 
    49             CALL iom_put( TRIM(cltra), trn(:,:,:,jn) * fse3t_n(:,:,:) ) 
    50          ELSE 
    51             CALL iom_put( TRIM(cltra), trn(:,:,:,jn) ) 
     44         CALL iom_put( TRIM(cltra), trn(:,:,:,jn) ) 
    5245         ENDIF 
    5346      END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv_crs.F90

    r5105 r6772  
    2929   USE crs , ONLY : e2e3u_msk , e1e3v_msk , e1e2w_msk,jpi_crs,jpj_crs 
    3030   USE timing 
     31   USE iom, ONLY: iom_put,iom_swap 
    3132 
    3233   IMPLICIT NONE 
    … …  
    9798#endif 
    9899 
    99   !    IF(lwp) WRITE(numout,*) 'TEST', e1e2t 
    100       !                                                   ! effective transport 
    101 !         IF(lwp) WRITE(numout,*) 'un', maxval(un(:,:,:)) 
    102 !         IF(lwp) WRITE(numout,*) 'un', minval(un(:,:,:)) 
    103 !         IF(lwp) WRITE(numout,*) 'vn', maxval(vn(:,:,:)) 
    104 !         IF(lwp) WRITE(numout,*) 'vn', minval(vn(:,:,:)) 
    105 !         IF(lwp) WRITE(numout,*) 'wn', maxval(wn(:,:,:)) 
    106 !         IF(lwp) WRITE(numout,*) 'wn', minval(wn(:,:,:)) 
    107100      DO jk = 1, jpkm1 
    108101         !                                                ! eulerian transport only 
    … …  
    113106      END DO 
    114107 
    115          IF(lwp)WRITE(numout,*)"jpi_crs jpj_crs jpk ",jpi_crs,jpj_crs,jpk 
    116          DO jk=1,jpk 
    117            DO jj = 1, jpj_crs 
    118                DO ji = 1, jpi_crs 
    119                   IF( zwn(ji,jj,jk) .NE. zwn(ji,jj,jk) )WRITE(narea+200,*)"trcadv_zwn",zwn(ji,jj,jk) ; call flush(narea+200) 
    120                END DO 
    121             END DO 
    122          END DO 
    123  
    124  
    125108      zwn(:,:,jpk) = 0.e0                                 ! no transport trough the bottom 
    126109 
    … …  
    129112      ! 
    130113      SELECT CASE ( nadv )                            !==  compute advection trend and add it to general trend  ==! 
    131 !cbr      CASE ( 1 )   ;    CALL tra_adv_cen2  ( kt, nittrc000, 'TRC',       zun, zvn, zwn, trb, trn, tra, jptra )   !  2nd order centered 
    132114      CASE ( 2 )   ;    CALL tra_adv_tvd_crs   ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )   !  TVD  
    133 !cbr      CASE ( 3 )   ;    CALL tra_adv_muscl ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb,      tra, jptra )   !  MUSCL  
    134 !cbr      CASE ( 4 )   ;    CALL tra_adv_muscl2( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )   !  MUSCL2  
    135 !cbr      CASE ( 5 )   ;    CALL tra_adv_ubs   ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )   !  UBS  
    136 !cbr      CASE ( 6 )   ;    CALL tra_adv_qck   ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )   !  QUICKEST  
    137115      ! 
    138116      CASE (-1 )                                      !==  esopa: test all possibility with control print  ==! 
    139 !         CALL tra_adv_cen2  ( kt, nittrc000, 'TRC',       zun, zvn, zwn, trb, trn, tra, jptra )           
    140 !         WRITE(charout, FMT="('adv1')")  ; CALL prt_ctl_trc_info(charout) 
    141 !                                           CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm,clinfo2='trd') 
    142117         CALL tra_adv_tvd_crs   ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )           
    143118         WRITE(charout, FMT="('adv2')")  ; CALL prt_ctl_trc_info(charout) 
    144                                            CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm,clinfo2='trd') 
    145 !         CALL tra_adv_muscl ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb,      tra, jptra )           
    146 !         WRITE(charout, FMT="('adv3')")  ; CALL prt_ctl_trc_info(charout) 
    147 !                                           CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm,clinfo2='trd') 
    148 !         CALL tra_adv_muscl2( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )           
    149 !         WRITE(charout, FMT="('adv4')")  ; CALL prt_ctl_trc_info(charout) 
    150 !                                           CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm,clinfo2='trd') 
    151 !         CALL tra_adv_ubs   ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )           
    152 !         WRITE(charout, FMT="('adv5')")  ; CALL prt_ctl_trc_info(charout) 
    153 !                                           CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm,clinfo2='trd') 
    154 !         CALL tra_adv_qck   ( kt, nittrc000, 'TRC', r2dt, zun, zvn, zwn, trb, trn, tra, jptra )           
    155 !         WRITE(charout, FMT="('adv6')")  ; CALL prt_ctl_trc_info(charout) 
    156119                                           CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm,clinfo2='trd') 
    157120         ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90

    r5602 r6772  
    2727   !!---------------------------------------------------------------------- 
    2828   USE oce_trc         ! ocean dynamics and tracers variables 
    29    USE trc             ! ocean passive tracers variables 
     29   USE trc, ONLY : nittrc000, tra, jptra,rdttrc,trb, trn,tra,ctrcnm            ! ocean passive tracers variables 
    3030   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    3131   USE prtctl_trc      ! Print control for debbuging 
    … …  
    3636   USE agrif_top_interp 
    3737# endif 
     38   USE crs, ONLY : ln_crs_top 
     39   USE ieee_arithmetic 
    3840 
    3941   IMPLICIT NONE 
    … …  
    8991      INTEGER, INTENT( in ) ::   kt     ! ocean time-step index 
    9092      ! 
    91       INTEGER  ::   jk, jn   ! dummy loop indices 
     93      INTEGER  ::   ji,jj,jk, jn   ! dummy loop indices 
    9294      REAL(wp) ::   zfact            ! temporary scalar 
    9395      CHARACTER (len=22) :: charout 
    … …  
    137139      ELSE 
    138140         ! Leap-Frog + Asselin filter time stepping 
    139          IF( lk_vvl ) THEN   ;   CALL tra_nxt_vvl( kt, nittrc000, rdttrc, 'TRC', trb, trn, tra,      & 
    140            &                                                                sbc_trc, sbc_trc_b, jptra )      ! variable volume level (vvl)  
    141          ELSE                ;   CALL tra_nxt_fix( kt, nittrc000,         'TRC', trb, trn, tra, jptra )      ! fixed    volume level  
     141         IF( lk_vvl ) THEN    
     142 
     143            IF( ln_crs_top )THEN  
     144               CALL tra_nxt_vvl_crs( kt, nittrc000, rdttrc, 'TRC', trb, trn, tra,      & 
     145              &                                              sbc_trc, sbc_trc_b, jptra )      ! variable volume level (vvl)  
     146            ELSE 
     147               CALL tra_nxt_vvl( kt, nittrc000, rdttrc, 'TRC', trb, trn, tra,      & 
     148              &                                          sbc_trc, sbc_trc_b, jptra )      ! variable volume level (vvl)  
     149            ENDIF 
     150         ELSE                   ;   CALL tra_nxt_fix( kt, nittrc000,         'TRC', trb, trn, tra, jptra )      ! fixed    volume level  
    142151         ENDIF 
    143152      ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r6101 r6772  
    1717   !!---------------------------------------------------------------------- 
    1818   USE oce_trc         ! ocean dynamics and active tracers variables 
    19    USE trc             ! ocean  passive tracers variables 
     19   USE trc , ONLY  : trn,tra,ln_top_euler,rdttrc,nittrc000,ln_rsttr,numrtr,ctrcnm,jptra,numrtw,nn_ice_tr,lrst_trc 
    2020   USE prtctl_trc      ! Print control for debbuging 
    21    USE iom, ONLY : iom_varid, iom_get, iom_rstput,jpdom_autoglo 
     21   USE iom  , ONLY : iom_varid, iom_get, iom_rstput,jpdom_autoglo 
    2222   USE trd_oce 
    2323   USE trdtra 
     24   USE ieee_arithmetic 
    2425 
    2526   IMPLICIT NONE 
    … …  
    135136 
    136137      ! 0. initialization 
     138      sbc_trc(:,:,:)=0._wp 
    137139      DO jn = 1, jptra 
    138140         ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90

    r6101 r6772  
    1414   !!---------------------------------------------------------------------- 
    1515   USE oce_trc         ! ocean dynamics and active tracers variables 
     16   USE crs, ONLY: fmmflx_crs 
    1617   USE trc             ! ocean passive tracers variables  
    1718   USE trcnam_trp      ! passive tracers transport namelist variables 
    … …  
    3132   USE trcrad          ! positivity                          (trc_rad routine) 
    3233   USE trcsbc          ! surface boundary condition          (trc_sbc routine) 
    33    USE trcsbc_crs      ! surface boundary condition          (trc_sbc routine) 
    3434   USE zpshde          ! partial step: hor. derivative       (zps_hde routine) 
    3535   USE zpshde_crs      ! partial step: hor. derivative       (zps_hde routine) 
    3636   USE dom_oce , ONLY : ln_crs, ln_isfcav 
    37    USE crs     , ONLY : jpi_crs,jpj_crs,wn_crs,ln_crs_top !cbr 
     37   USE crs     , ONLY : jpi_crs,jpj_crs,wn_crs,ln_crs_top,sbc_trc_crs,sbc_trc_b_crs 
    3838   USE ldfslp_crs 
    3939#if defined key_agrif 
    … …  
    4141   USE agrif_top_update ! tracers updates 
    4242#endif 
     43   USE ieee_arithmetic 
    4344 
    4445   IMPLICIT NONE 
    … …  
    7576      IF( .NOT. lk_c1d ) THEN 
    7677         ! 
    77          IF( ln_crs_top ) THEN ;    CALL trc_sbc_crs( kstp ) 
    78          ELSE              ;    CALL trc_sbc( kstp ) 
    79          ENDIF 
     78         CALL test(kstp,1) 
     79                               CALL trc_sbc( kstp ) 
     80         CALL test(kstp,2) 
    8081         IF( ln_crs_top ) THEN ;    CALL trc_bbl_crs( kstp ) 
    8182         ELSE              ;    CALL trc_bbl( kstp ) 
    … …  
    8384         IF( ln_trcdmp )        CALL trc_dmp( kstp )            ! internal damping trends 
    8485 
     86         CALL test(kstp,3) 
    8587         IF( ln_crs_top ) THEN ;    CALL trc_adv_crs( kstp ) 
    8688         ELSE              ;    CALL trc_adv( kstp ) 
    8789         ENDIF 
    8890 
     91         CALL test(kstp,4) 
    8992         IF( ln_trcdmp_clo )    CALL trc_dmp_clo( kstp )        ! internal damping trends on closed seas only 
    9093         IF( ln_crs_top ) THEN ;    CALL trc_ldf_crs( kstp ) 
    9194         ELSE              ;    CALL trc_ldf( kstp ) 
    9295         ENDIF 
     96         CALL test(kstp,5) 
    9397         IF( .NOT. lk_offline .AND. lk_zdfkpp )    & 
    9498            &                   CALL trc_kpp( kstp )            ! KPP non-local tracer fluxes 
    … …  
    99103         ELSE              ;    CALL trc_zdf( kstp ) 
    100104         ENDIF 
     105         CALL test(kstp,6) 
     106 
    101107                                CALL trc_nxt( kstp )            ! tracer fields at next time step      
     108         CALL test(kstp,10) 
    102109         IF( ln_trcrad )        CALL trc_rad( kstp )            ! Correct artificial negative concentrations 
    103110 
    … …  
    132139      ! 
    133140   END SUBROUTINE trc_trp 
     141 
    134142   SUBROUTINE test(kt,i) 
    135143   INTEGER,INTENT(IN) :: kt,i 
    136144   REAL(wp)::zmin,zmax 
    137    INTEGER :: ii,jj,kk 
     145   INTEGER :: ji,jj,jk 
    138146   zmin=MINVAL( trb(2:jpi-1,2:jpj-1,:,1),mask=(tmask(2:jpi-1,2:jpj-1,:)==1)) ; CALL mpp_min(zmin) 
    139147   zmax=MAXVAL( trb(2:jpi-1,2:jpj-1,:,1),mask=(tmask(2:jpi-1,2:jpj-1,:)==1)) ; CALL mpp_max(zmax) 
    … …  
    145153   zmax=MAXVAL( tra(2:jpi-1,2:jpj-1,:,1),mask=(tmask(2:jpi-1,2:jpj-1,:)==1)) ; CALL mpp_max(zmax) 
    146154   IF(lwp)WRITE(numout,*)"trctrp a ",kt,i,zmin,zmax    
    147    zmin=MINVAL( tra(2:jpi-1,2:jpj-1,30,1),mask=(tmask(2:jpi-1,2:jpj-1,30)==1)) ; CALL mpp_min(zmin) 
    148    zmax=MAXVAL( tra(2:jpi-1,2:jpj-1,30,1),mask=(tmask(2:jpi-1,2:jpj-1,30)==1)) ; CALL mpp_max(zmax) 
    149155 
    150156   END SUBROUTINE test 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r6101 r6772  
    102102   USE crs , ONLY :   e1v        =>   e1v_crs        !: horizontal scale factors at v-point (m) 
    103103   USE crs , ONLY :   e2v        =>   e2v_crs        !: horizontal scale factors at v-point (m)   
    104    USE crs , ONLY :   e3t        =>  e3t_crs         !: vertical scale factors at t- 
    105    USE crs , ONLY :   e3t_0      =>  e3t_crs         !: vertical scale factors at t- 
    106    USE crs , ONLY :   fse3t      =>  e3t_crs 
    107    USE crs , ONLY :   fse3t_b      =>  e3t_crs 
    108    USE crs , ONLY :   fse3t_a      =>  e3t_crs 
    109    USE crs , ONLY :   fse3w      =>  e3w_crs 
    110    USE crs , ONLY :   e3u        =>  e3u_crs         !: vertical scale factors at u- 
    111    USE crs , ONLY :   e3u_0      =>  e3u_crs         !: vertical scale factors at u- 
    112    USE crs , ONLY :   e3v        =>  e3v_crs         !: vertical scale factors v- 
    113    USE crs , ONLY :   e3v_0      =>  e3v_crs         !: vertical scale factors v- 
    114    USE crs , ONLY :   e3w        =>  e3w_crs         !: w-points (m) 
    115    USE crs , ONLY :   e3w_0      =>  e3w_crs         !: w-points (m) 
    116    USE crs , ONLY :   e3f        =>  e3f_crs         !: f-points (m) 
     104 
     105#if defined key_vvl  
     106   USE crs , ONLY :   e3t        =>  e3t_n_crs         !: vertical scale factors at t- 
     107   USE crs , ONLY :   e3u        =>  e3u_n_crs         !: vertical scale factors at u- 
     108   USE crs , ONLY :   e3v        =>  e3v_n_crs         !: vertical scale factors v- 
     109   USE crs , ONLY :   e3w        =>  e3w_n_crs         !: w-points (m) 
     110   USE crs , ONLY :   e3t_n      =>  e3t_n_crs         !: vertical scale factors at t- 
     111   USE crs , ONLY :   e3u_n      =>  e3u_n_crs         !: vertical scale factors at u- 
     112   USE crs , ONLY :   e3v_n      =>  e3v_n_crs         !: vertical scale factors v- 
     113   USE crs , ONLY :   e3w_n      =>  e3w_n_crs         !: w-points (m) 
     114   USE crs , ONLY :   e3t_a      =>  e3t_a_crs         !: vertical scale factors at t- 
     115   USE crs , ONLY :   e3u_a      =>  e3u_a_crs         !: vertical scale factors at u- 
     116   USE crs , ONLY :   e3v_a      =>  e3v_a_crs         !: vertical scale factors v- 
     117   USE crs , ONLY :   e3w_a      =>  e3w_a_crs         !: w-points (m) 
     118   USE crs , ONLY :   fse3t      =>  e3t_n_crs         !: vertical scale factors at t- 
     119   USE crs , ONLY :   fse3u      =>  e3u_n_crs         !: vertical scale factors at u- 
     120   USE crs , ONLY :   fse3v      =>  e3v_n_crs         !: vertical scale factors v- 
     121   USE crs , ONLY :   fse3w      =>  e3w_n_crs         !: w-points (m) 
     122   USE crs , ONLY :   gdept      =>  gdept_n_crs       !: depth of t-points (m) 
     123   USE crs , ONLY :   gdept_crs  =>  gdept_n_crs       !: depth of t-points (m) 
     124   USE crs , ONLY :   gdept_n    =>  gdept_n_crs       !: depth of t-points (m) 
     125   USE crs , ONLY :   fse3t_b    =>  e3t_b_crs         !: vertical scale factors at t- 
     126   USE crs , ONLY :   fse3t_n    =>  e3t_n_crs         !: vertical scale factors at t- 
     127   USE crs , ONLY :   fse3t_a    =>  e3t_a_crs         !: vertical scale factors at t- 
     128   USE crs , ONLY :   fsdept_n   =>  gdept_n_crs       !: depth of t-points (m) 
     129   USE crs , ONLY :   e3t_max_crs => e3t_max_n_crs 
     130   USE crs , ONLY :   e3u_max_crs => e3u_max_n_crs 
     131   USE crs , ONLY :   e3v_max_crs => e3v_max_n_crs 
     132   USE crs , ONLY :   e3w_max_crs => e3w_max_n_crs 
     133#else 
     134   USE crs , ONLY :   e3t        =>  e3t_0_crs         !: vertical scale factors at t- 
     135   USE crs , ONLY :   e3u        =>  e3u_0_crs         !: vertical scale factors at u- 
     136   USE crs , ONLY :   e3v        =>  e3v_0_crs         !: vertical scale factors v- 
     137   USE crs , ONLY :   e3w        =>  e3w_0_crs         !: w-points (m) 
     138   USE crs , ONLY :   e3t_n      =>  e3t_0_crs         !: vertical scale factors at t- 
     139   USE crs , ONLY :   e3u_n      =>  e3u_0_crs         !: vertical scale factors at u- 
     140   USE crs , ONLY :   e3v_n      =>  e3v_0_crs         !: vertical scale factors v- 
     141   USE crs , ONLY :   e3w_n      =>  e3w_0_crs         !: w-points (m) 
     142   USE crs , ONLY :   e3t_a      =>  e3t_0_crs         !: vertical scale factors at t- 
     143   USE crs , ONLY :   e3u_a      =>  e3u_0_crs         !: vertical scale factors at u- 
     144   USE crs , ONLY :   e3v_a      =>  e3v_0_crs         !: vertical scale factors v- 
     145   USE crs , ONLY :   e3w_a      =>  e3w_0_crs         !: w-points (m) 
     146   USE crs , ONLY :   fse3t      =>  e3t_0_crs         !: vertical scale factors at t- 
     147   USE crs , ONLY :   fse3u      =>  e3u_0_crs         !: vertical scale factors at u- 
     148   USE crs , ONLY :   fse3v      =>  e3v_0_crs         !: vertical scale factors v- 
     149   USE crs , ONLY :   fse3w      =>  e3w_0_crs         !: w-points (m) 
     150   USE crs , ONLY :   gdept      =>  gdept_0_crs       !: depth of t-points (m) 
     151   USE crs , ONLY :   gdepw      =>  gdepw_0_crs       !: depth of t-points (m) 
     152   USE crs , ONLY :   gdept_crs  =>  gdept_0_crs       !: depth of t-points (m) 
     153   USE crs , ONLY :   gdepw_crs  =>  gdepw_0_crs       !: depth of t-points (m) 
     154   USE crs , ONLY :   gdept_n    =>  gdept_0_crs       !: depth of t-points (m) 
     155   USE crs , ONLY :   fse3t_b    =>  e3t_0_crs         !: vertical scale factors at t- 
     156   USE crs , ONLY :   fse3t_n    =>  e3t_0_crs         !: vertical scale factors at t- 
     157   USE crs , ONLY :   fse3t_a    =>  e3t_0_crs         !: vertical scale factors at t- 
     158   USE crs , ONLY :   fsdept_n   =>  gdept_0_crs       !: depth of t-points (m) 
     159   USE crs , ONLY :   e3t_max_crs => e3t_max_0_crs 
     160   USE crs , ONLY :   e3u_max_crs => e3u_max_0_crs 
     161   USE crs , ONLY :   e3v_max_crs => e3v_max_0_crs 
     162   USE crs , ONLY :   e3w_max_crs => e3w_max_0_crs 
     163#endif 
     164   USE crs , ONLY :   e3t_0        =>  e3t_0_crs         !: vertical scale factors at t- 
     165   USE crs , ONLY :   e3u_0        =>  e3u_0_crs         !: vertical scale factors at t- 
     166   USE crs , ONLY :   e3v_0        =>  e3v_0_crs         !: vertical scale factors at t- 
     167   USE crs , ONLY :   e3w_0        =>  e3w_0_crs         !: vertical scale factors at t- 
     168 
    117169   USE crs , ONLY :   ff         =>  ff_crs         !: f-points (m) 
    118  
    119    USE crs , ONLY :   gdept_0    =>  gdept_crs       !: depth of t-points (m) 
     170   USE crs , ONLY :   gdept_0    =>  gdept_0_crs       !: depth of t-points (m) 
    120171   USE dom_oce , ONLY :   gdept_1d   =>  gdept_1d      !: depth of t-points (m) 
    121172#if defined key_zco 
    122    USE crs , ONLY :   gdept      =>  gdept_crs       !: depth of t-points (m) 
     173   USE crs , ONLY :   gdept      =>  gdept_0_crs       !: depth of t-points (m) 
    123174   USE crs , ONLY :   gdepw      =>  gdepw_crs       !: depth of t-points (m) 
    124175#endif 
    … …  
    140191   USE crs , ONLY :   wn      =>    wn_crs      !: vertical velocity (m s-1)   
    141192   USE crs , ONLY :   tsn     =>    tsn_crs     !: 4D array contaning ( tn, sn ) 
    142    USE oce , ONLY :   tsb     =>    tsb     !: 4D array contaning ( tb, sb ) 
    143    USE oce , ONLY :   tsa     =>    tsa     !: 4D array contaning ( ta, sa ) 
    144    USE oce , ONLY :   rhop    =>    rhop    !: potential volumic mass (kg m-3)  
     193   USE crs , ONLY :   tsb     =>    tsb_crs     !: 4D array contaning ( tb, sb ) 
     194   USE crs , ONLY :   tsa     =>    tsa_crs     !: 4D array contaning ( ta, sa ) 
     195   USE crs , ONLY :   rhop    =>    rhop_crs    !: potential volumic mass (kg m-3)  
    145196   USE crs , ONLY :   rhd     =>    rhd_crs    !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 
    146197   USE crs , ONLY :   rn2b    =>    rb2_crs     !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 
    … …  
    160211   USE crs , ONLY :   emp_b      =>    emp_b_crs      !: freshwater budget: volume flux               [Kg/m2/s] 
    161212   USE crs , ONLY :   sfx        =>    sfx_crs        !: freshwater budget: concentration/dillution   [Kg/m2/s] 
     213   USE crs , ONLY :   sbc_trc_b  =>    sbc_trc_b_crs      !: freshwater budget: volume flux               [Kg/m2/s] 
     214   USE crs , ONLY :   sbc_trc    =>    sbc_trc_crs      !: freshwater budget: volume flux               [Kg/m2/s] 
    162215   USE crs , ONLY :   fmmflx     =>    fmmflx_crs     !: freshwater budget: volume flux               [Kg/m2/s] 
    163216   USE crs , ONLY :   rnf        =>    rnf_crs        !: river runoff   [Kg/m2/s] 
    … …  
    169222   USE crs , ONLY :  ahtt     =>   ahtt_crs        !: lateral diffusivity coef. at t-points 
    170223   USE ldftra_oce , ONLY :  rldf     =>   rldf 
    171  
     224   USE crs , ONLY :  trc_i => trc_i_crs 
     225   USE crs , ONLY :  trc_o => trc_o_crs 
    172226   USE crs , ONLY :   avt        =>   avt_crs         !: vert. diffusivity coef. at w-point for temp   
    173227#if defined key_zdfddm 
    … …  
    262316   USE dom_oce , ONLY :   e3t        =>  e3t_0         !: vertical scale factors at t- 
    263317   USE dom_oce , ONLY :   e3t_0      =>  e3t_0         !: vertical scale factors at t- 
     318#if defined key_vvl  
     319   USE dom_oce , ONLY :   fse3t_b    =>  e3t_b 
     320   USE dom_oce , ONLY :   fse3t_n    =>  e3t_n 
     321   USE dom_oce , ONLY :   fse3t      =>  e3t_n 
     322   USE dom_oce , ONLY :   fse3u      =>  e3u_n 
     323   USE dom_oce , ONLY :   fse3v      =>  e3v_n 
     324   USE dom_oce , ONLY :   fse3w      =>  e3w_n 
     325   USE dom_oce , ONLY :   fse3t_a    =>  e3t_a 
     326   USE dom_oce , ONLY :     e3t_b    =>  e3t_b 
     327   USE dom_oce , ONLY :     e3t_n    =>  e3t_n 
     328   USE dom_oce , ONLY :     e3t_a    =>  e3t_a 
     329   USE dom_oce , ONLY :     e3u_n    =>  e3u_n 
     330   USE dom_oce , ONLY :     e3v_n    =>  e3v_n 
     331   USE dom_oce , ONLY :   e3u        =>  e3u_n         !: vertical scale factors at u- 
     332   USE dom_oce , ONLY :   e3u_0      =>  e3u_0         !: vertical scale factors at u- 
     333   USE dom_oce , ONLY :   e3v        =>  e3v_n         !: vertical scale factors v- 
     334   USE dom_oce , ONLY :   e3v_0      =>  e3v_0         !: vertical scale factors v- 
     335   USE dom_oce , ONLY :   e3w_n      =>  e3w_n         !: w-points (m) 
     336   USE dom_oce , ONLY :   e3w        =>  e3w_n         !: w-points (m) 
     337   USE dom_oce , ONLY :   e3w_0      =>  e3w_0         !: w-points (m) 
     338   USE dom_oce , ONLY :   e3f        =>  e3f_n         !: f-points (m) 
     339   USE dom_oce , ONLY :   gdept_n    =>  gdept_n         !: f-points (m) 
     340   USE dom_oce , ONLY :  fsdept_n    =>  gdept_n         !: f-points (m) 
     341#else 
     342   USE dom_oce , ONLY :   fse3t_n    =>  e3t_0 
    264343   USE dom_oce , ONLY :   fse3t      =>  e3t_0 
    265    USE dom_oce , ONLY :   fse3t_b      =>  e3t_0 
    266    USE dom_oce , ONLY :   fse3t_a      =>  e3t_0 
     344   USE dom_oce , ONLY :   fse3u      =>  e3u_0 
     345   USE dom_oce , ONLY :   fse3v      =>  e3v_0 
    267346   USE dom_oce , ONLY :   fse3w      =>  e3w_0 
     347   USE dom_oce , ONLY :   fse3t_b    =>  e3t_0 
     348   USE dom_oce , ONLY :   fse3t_a    =>  e3t_0 
     349   USE dom_oce , ONLY :     e3t_a    =>  e3t_0 
    268350   USE dom_oce , ONLY :   e3u        =>  e3u_0         !: vertical scale factors at u- 
    269351   USE dom_oce , ONLY :   e3u_0      =>  e3u_0         !: vertical scale factors at u- 
    … …  
    273355   USE dom_oce , ONLY :   e3w_0      =>  e3w_0         !: w-points (m) 
    274356   USE dom_oce , ONLY :   e3f        =>  e3f_0         !: f-points (m) 
     357   USE dom_oce , ONLY :   gdept_n    =>  gdept_0         !: f-points (m) 
     358   USE dom_oce , ONLY :  fsdept_n    =>  gdept_0         !: f-points (m) 
     359#endif 
    275360   USE dom_oce , ONLY :   ff         =>  ff         !: f-points (m) 
    276361   USE dom_oce , ONLY :   gdept_0    =>  gdept_0         !: f-points (m) 
    … …  
    349434   USE sbc_oce , ONLY :   rnf        =>    rnf        !: river runoff   [Kg/m2/s] 
    350435   USE sbc_oce , ONLY :   ln_dm2dc   =>    ln_dm2dc   !: Diurnal Cycle  
    351    USE sbc_oce , ONLY :   ncpl_qsr_freq   =>   ncpl_qsr_freq   !: qsr coupling frequency per days from atmospher 
    352    USE sbc_oce , ONLY :   ln_rnf     =>    ln_rnf     !: runoffs / runoff mouths 
    353436   USE sbc_oce , ONLY :   fr_i       =>    fr_i       !: ice fraction (between 0 to 1) 
    354    USE sbc_oce , ONLY :   nn_ice_embd => nn_ice_embd  !: flag for  levitating/embedding sea-ice in the ocean 
    355437   USE traqsr  , ONLY :   rn_abs     =>    rn_abs     !: fraction absorbed in the very near surface 
    356438   USE traqsr  , ONLY :   rn_si0     =>    rn_si0     !: very near surface depth of extinction 
    … …  
    360442   USE sbcrnf  , ONLY :   h_rnf      =>    h_rnf      !: river runoff   [Kg/m2/s] 
    361443   USE sbcrnf  , ONLY :   nk_rnf     =>    nk_rnf     !: depth of runoff in model level 
     444   USE trc     , ONLY :   sbc_trc_b  =>    sbc_trc_b  !: freshwater budget: volume flux               [Kg/m2/s] 
     445   USE trc     , ONLY :   sbc_trc    =>    sbc_trc    !: freshwater budget: volume flux               [Kg/m2/s] 
     446   USE trc , ONLY :  trc_i => trc_i 
     447   USE trc , ONLY :  trc_o => trc_o 
    362448 
    363449   USE trc_oce 
    … …  
    407493   USE sbc_oce , ONLY : nn_ice_embd 
    408494   USE sbc_oce , ONLY : ln_cpl 
     495   USE sbc_oce , ONLY : ln_rnf 
    409496   USE sbc_oce , ONLY : ncpl_qsr_freq 
    410497 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcdta.F90

    r6101 r6772  
    3737!$AGRIF_END_DO_NOT_TREAT 
    3838   !! * Substitutions 
    39 #  include "domzgr_substitute.h90" 
     39!cbr #  include "domzgr_substitute.h90" 
    4040   !!---------------------------------------------------------------------- 
    4141   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcice.F90

    r5602 r6772  
    1414 
    1515   USE oce_trc         ! shared variables between ocean and passive tracers 
    16    USE trc             ! passive tracers common variables 
     16   USE trc, ONLY : nn_ice_tr,lk_pisces,lk_cfc,lk_c14b,lk_my_trc             ! passive tracers common variables 
    1717   USE trcice_cfc      ! CFC      initialisation 
    1818   USE trcice_pisces   ! PISCES   initialisation 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r6101 r6772  
    7777      IF( l_trcdm2dc )   CALL trc_mean_qsr( kt ) 
    7878      !     
    79       IF( nn_dttrc /= 1 )   CALL trc_sub_stp( kt )  ! averaging physical variables for sub-stepping 
     79!cbr      IF( nn_dttrc /= 1 )   CALL trc_sub_stp( kt )  ! averaging physical variables for sub-stepping 
    8080      !     
    8181      IF( MOD( kt , nn_dttrc ) == 0 ) THEN      ! only every nn_dttrc time step 
    … …  
    102102         IF( lk_trdmxl_trc  )      CALL trd_mxl_trc  ( kt )       ! trends: Mixed-layer 
    103103         ! 
    104          IF( nn_dttrc /= 1   )     CALL trc_sub_reset( kt )       ! resetting physical variables when sub-stepping 
     104!cbr         IF( nn_dttrc /= 1   )     CALL trc_sub_reset( kt )       ! resetting physical variables when sub-stepping 
    105105         ! 
    106106      ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcsub.F90

    r5602 r6772  
    4545 
    4646   !!* Substitution 
    47 #  include "top_substitute.h90" 
     47!!#  include "top_substitute.h90" 
    4848   !!---------------------------------------------------------------------- 
    4949   !! NEMO/TOP 3.3 , NEMO Consortium (2010) 
    … …  
    111111          ! 
    112112          sshn_tm  (:,:)         = sshn_tm  (:,:)         + sshn  (:,:)  
    113           rnf_tm   (:,:)         = rnf_tm   (:,:)         + rnf   (:,:)  
    114 !cbr          h_rnf_tm (:,:)         = h_rnf_tm (:,:)         + h_rnf (:,:)  
     113          IF( ln_rnf )THEN 
     114             rnf_tm   (:,:)         = rnf_tm   (:,:)         + rnf   (:,:)  
     115             h_rnf_tm (:,:)         = h_rnf_tm (:,:)         + h_rnf (:,:)  
     116          ENDIF 
    115117          hmld_tm  (:,:)         = hmld_tm  (:,:)         + hmld  (:,:) 
    116118          fr_i_tm  (:,:)         = fr_i_tm  (:,:)         + fr_i  (:,:) 
    … …  
    151153         ssha_temp  (:,:)        = ssha  (:,:) 
    152154         rnf_temp   (:,:)        = rnf   (:,:) 
    153 !cbr         h_rnf_temp (:,:)        = h_rnf (:,:) 
    154          hmld_temp  (:,:)        = hmld  (:,:) 
     155         IF( ln_rnf )THEN 
     156            h_rnf_temp (:,:)        = h_rnf (:,:) 
     157            hmld_temp  (:,:)        = hmld  (:,:) 
     158         ENDIF 
    155159         fr_i_temp  (:,:)        = fr_i  (:,:) 
    156160         emp_temp   (:,:)        = emp   (:,:) 
    … …  
    196200# endif 
    197201         sshn_tm  (:,:)          = sshn_tm    (:,:)       + sshn  (:,:)  
    198          rnf_tm   (:,:)          = rnf_tm     (:,:)       + rnf   (:,:)  
    199 !cbr         h_rnf_tm (:,:)          = h_rnf_tm   (:,:)       + h_rnf (:,:)  
     202         IF( ln_rnf )THEN 
     203            rnf_tm   (:,:)          = rnf_tm     (:,:)       + rnf   (:,:)  
     204            h_rnf_tm (:,:)          = h_rnf_tm   (:,:)       + h_rnf (:,:)  
     205         ENDIF 
    200206         hmld_tm  (:,:)          = hmld_tm    (:,:)       + hmld  (:,:) 
    201207         fr_i_tm  (:,:)          = fr_i_tm    (:,:)       + fr_i  (:,:) 
    … …  
    207213         sshn     (:,:)          = sshn_tm    (:,:) * r1_ndttrcp1  
    208214         sshb     (:,:)          = sshb_hold  (:,:) 
    209          rnf      (:,:)          = rnf_tm     (:,:) * r1_ndttrcp1  
    210 !cbr         h_rnf    (:,:)          = h_rnf_tm   (:,:) * r1_ndttrcp1  
     215         IF( ln_rnf )THEN 
     216            rnf      (:,:)          = rnf_tm     (:,:) * r1_ndttrcp1  
     217            h_rnf    (:,:)          = h_rnf_tm   (:,:) * r1_ndttrcp1  
     218         ENDIF 
    211219         hmld     (:,:)          = hmld_tm    (:,:) * r1_ndttrcp1  
    212220         !  variables that are initialized after averages 
    … …  
    319327#endif 
    320328      sshn_tm  (:,:) = sshn  (:,:)  
    321       rnf_tm   (:,:) = rnf   (:,:)  
    322 !cbr      h_rnf_tm (:,:) = h_rnf (:,:)  
     329      IF( ln_rnf )THEN 
     330         rnf_tm   (:,:) = rnf   (:,:)  
     331         h_rnf_tm (:,:) = h_rnf (:,:)  
     332      ENDIF 
    323333      hmld_tm  (:,:) = hmld  (:,:) 
    324334 
    … …  
    378388      sshb  (:,:)     =  sshb_temp  (:,:) 
    379389      ssha  (:,:)     =  ssha_temp  (:,:) 
    380       rnf   (:,:)     =  rnf_temp   (:,:) 
    381 !cbr      h_rnf (:,:)     =  h_rnf_temp (:,:) 
     390      IF( ln_rnf )THEN 
     391         rnf   (:,:)     =  rnf_temp   (:,:) 
     392         h_rnf (:,:)     =  h_rnf_temp (:,:) 
     393      ENDIF 
    382394      ! 
    383395      hmld  (:,:)     =  hmld_temp  (:,:) 
    … …  
    427439      emp_b_hold (:,:) = emp   (:,:) 
    428440      sshn_tm    (:,:) = sshn  (:,:)  
    429       rnf_tm     (:,:) = rnf   (:,:)  
    430 !cbr      h_rnf_tm   (:,:) = h_rnf (:,:)  
     441      IF( ln_rnf )THEN 
     442         rnf_tm     (:,:) = rnf   (:,:)  
     443         h_rnf_tm   (:,:) = h_rnf (:,:)  
     444      ENDIF 
    431445      hmld_tm    (:,:) = hmld  (:,:) 
    432446      fr_i_tm    (:,:) = fr_i  (:,:) 
Note: See TracChangeset for help on using the changeset viewer.