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 3895 – NEMO

Changeset 3895


Ignore:
Timestamp:
2013-05-02T14:36:47+02:00 (11 years ago)
Author:
cetlod
Message:

2013/dev_r3411_CNRS4_IOCRS: minor corrections + style

Location:
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM
Files:
2 added
8 edited

Legend:

Unmodified
Added
Removed

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/CONFIG/ORCA2_LIM_CRS/EXP00/iodef.xml

    r3860 r3895  
    349349             <field ref="sss"     name="sosaline" /> 
    350350             <field ref="ssh"     name="sossheig" /> 
    351              <field ref="eken"         name="energkin"  /> 
     351             <field ref="eken"    name="energkin"  /> 
    352352          </file> 
    353353 
    … …  
    362362          </file> 
    363363       
    364 <!--  
    365 ............................................................................................................ 
    366            example of 3 types of 1d files 
    367 ............................................................................................................ 
    368 --> 
    369    <!-- automatic definition of the name based on id="1d_grid_T"  
    370         => this name is used as the radical for all file names of this group 
    371         => add a suffix to be sure that all files names of this group are different   --> 
    372    <group id="1d_grid_T" name="auto" description="ocean T grid variables" > 
    373      <!-- mooring: automatic definition of the file name suffix based on id="0n180wT"  --> 
    374      <file id="0n180wT" name_suffix="auto" > 
    375        <group id="0n180wT" zoom_ref="0n180wT" >    <!-- group of variables sharing the same zoom --> 
    376          <field ref="toce" name="votemper"  /> 
    377          <field ref="uoce" name="vozocrtx"  />     <!-- include a U-grid variable in the list => switch to T-grid --> 
    378               <field ref="eken"         name="energkin"  /> 
    379  
    380        </group> 
    381      </file> 
    382      <!-- Equatorial section: automatic definition of the file name suffix based on id="EqT" --> 
    383      <file id="EqT" name_suffix="auto" > 
    384        <group id="EqT" zoom_ref="EqT" > 
    385          <field ref="toce" name="votemper"  /> 
    386        </group> 
    387      </file> 
    388      <!-- global file with different operations on data   --> 
    389      <file id="global" > 
    390        <field ref="sst"    name="sst_1d_ave"                       />     <!-- mean --> 
    391        <field ref="sst"    name="sst_1d_max"  operation="t_max(X)" />     <!-- max --> 
    392             <field ref="M2x"     name="M2_x_elev"  /> 
    393             <field ref="M2y"     name="M2_y_elev"  /> 
    394      </file> 
    395  
    396    </group> 
    397  
    398         <!-- variables available with key_float, instantaneous fields --> 
    399 <!-- 
    400         <file id="floats"  description="floats variables"> 
    401             <field ref="traj_lon"   name="floats_longitude"   freq_op="86400" /> 
    402             <field ref="traj_lat"   name="floats_latitude"    freq_op="86400" /> 
    403             <field ref="traj_dep"   name="floats_depth"       freq_op="86400" /> 
    404             <field ref="traj_temp"  name="floats_temperature" freq_op="86400" /> 
    405             <field ref="traj_salt"  name="floats_salinity"    freq_op="86400" /> 
    406             <field ref="traj_dens"  name="floats_density"     freq_op="86400" /> 
    407             <field ref="traj_group" name="floats_group"       freq_op="86400" /> 
    408         </file> 
    409 --> 
    410  
    411364      </group> 
    412365 
    … …  
    422375     <field ref="sss"          name="sosaline"  /> 
    423376     <field ref="ssh"          name="sossheig"  /> 
    424      <field ref="empmr"        name="sowaflup"  /> 
    425      <field ref="qsr"          name="soshfldo"  /> 
    426      <field ref="empsmr"       name="sowaflcd"  /> 
    427      <field ref="qt"           name="sohefldo"  /> 
    428      <field ref="mldr10_1"     name="somxl010"  /> 
    429      <field ref="mldkz5"       name="somixhgt"  /> 
    430      <field ref="ice_cover"    name="soicecov"  /> 
    431      <field ref="wspd"         name="sowindsp"  /> 
    432      <field ref="qrp"          name="sohefldp"  /> 
    433      <field ref="erp"          name="sowafldp"  /> 
    434      <field ref="mlddzt"       name="sothedep"  /> 
    435      <field ref="20d"          name="so20chgt"  /> 
    436      <field ref="28d"          name="so28chgt"  /> 
    437      <field ref="hc300"        name="sohtc300"  /> 
    438      <field ref="ist_ipa"      name="soicetem"  /> 
    439      <field ref="icealb_cea"   name="soicealb"  />    
    440377   </file> 
    441378 
    … …  
    448385           <field ref="ssh_crs"     name="sossheig" /> 
    449386           <field ref="hdiv_crs"    name="vohdiver" /> 
    450            <field ref="eken_crs"    name="energkin" /> 
    451387        </file>    
    452388 
    453389   <file id="5d_grid_U" name="auto" description="ocean U grid variables" > 
    454390     <field ref="uoce"         name="vozocrtx"  /> 
    455      <field ref="uoce_eiv"     name="vozoeivu"  /> 
    456      <field ref="utau"         name="sozotaux"  /> 
    457391   </file> 
    458392 
    … …  
    465399   <file id="5d_grid_V" name="auto" description="ocean V grid variables" > 
    466400     <field ref="voce"         name="vomecrty"  /> 
    467      <field ref="voce_eiv"     name="vomeeivv"  /> 
    468      <field ref="vtau"         name="sometauy"  /> 
    469401   </file> 
    470402 
    … …  
    477409   <file id="5d_grid_W" name="auto" description="ocean W grid variables" > 
    478410     <field ref="woce"         name="vovecrtz" /> 
    479      <field ref="woce_eiv"     name="voveeivw" /> 
    480      <field ref="avt"          name="votkeavt" /> 
    481      <field ref="avt_evd"      name="votkeevd" /> 
    482      <field ref="avm"          name="votkeavm" /> 
    483      <field ref="avm_evd"      name="votkeevm" /> 
    484      <field ref="avs"          name="voddmavs" /> 
    485      <field ref="aht2d"        name="soleahtw" /> 
    486      <field ref="aht2d_eiv"    name="soleaeiw" /> 
    487411   </file> 
    488412 
    … …  
    491415        </file>    
    492416    
    493    <file id="5d_icemod" name="auto" description="ice variables" > 
    494      <field ref="ice_pres"                     /> 
    495      <field ref="snowthic_cea" name="isnowthi" /> 
    496      <field ref="icethic_cea"  name="iicethic" /> 
    497      <field ref="iceprod_cea"  name="iiceprod" /> 
    498      <field ref="ist_ipa"      name="iicetemp" /> 
    499      <field ref="ioceflxb"     name="ioceflxb" /> 
    500      <field ref="uice_ipa"     name="iicevelu" /> 
    501      <field ref="vice_ipa"     name="iicevelv" /> 
    502      <field ref="utau_ice"     name="iicestru" /> 
    503      <field ref="vtau_ice"     name="iicestrv" /> 
    504      <field ref="qsr_io_cea"   name="iicesflx" /> 
    505      <field ref="qns_io_cea"   name="iicenflx" /> 
    506      <field ref="snowpre"      name="isnowpre" /> 
    507    </file> 
    508     
    509417      </group> 
    510418       
    511419      <group id="1m" output_freq="-1"     output_level="10" enabled=".FALSE.">                      <!-- real monthly files --> 
    512  
    513    <file id="1m_grid_T" name="auto" description="ocean T grid variables" > 
    514      <field ref="sst"          name="sosstsst"  /> 
    515    </file>    
    516  
    517420      </group> 
    518421 
    … …  
    530433 
    531434      <group id="1y" output_freq="-12"    output_level="10" enabled=".FALSE.">                      <!-- real yearly files --> 
    532  
    533    <file id="1y_grid_T" name="auto" description="ocean T grid variables" > 
    534      <field ref="mldr10_1"     name="sobowlin"  operation="t_max(X)" /> 
    535    </file> 
    536  
    537435      </group> 
    538436 

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/CONFIG/ORCA2_LIM_CRS/MY_SRC/lib_mpp.F90

    r3864 r3895  
    6161   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn 
    6262   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
    63    PUBLIC   mpp_ini_north 
     63   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    6464   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    6565   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    … …  
    328328      REAL(wp) ::   zland 
    329329      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    330       REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
    331       REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
     330      REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE ::   t3ns, t3sn   ! 3d for north-south & south-north 
     331      REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE ::   t3ew, t3we   ! 3d for east-west & west-east 
    332332 
    333333      !!---------------------------------------------------------------------- 
    334334       
    335       ALLOCATE( zt3ns(jpi,jprecj,jpk,2)   , zt3sn(jpi,jprecj,jpk,2)   ,   & 
    336          &      zt3ew(jpj,jpreci,jpk,2)   , zt3we(jpj,jpreci,jpk,2)) 
     335      ALLOCATE( t3ns(jpi,jprecj,jpk,2)   , t3sn(jpi,jprecj,jpk,2)   ,   & 
     336         &      t3ew(jpj,jpreci,jpk,2)   , t3we(jpj,jpreci,jpk,2)) 
    337337          
    338338      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    … …  
    383383         iihom = nlci-nreci 
    384384         DO jl = 1, jpreci 
    385             zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    386             zt3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     385            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
     386            t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
    387387         END DO 
    388388      END SELECT   
    … …  
    393393      SELECT CASE ( nbondi )  
    394394      CASE ( -1 ) 
    395          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
    396          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
     395         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 ) 
     396         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
    397397         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    398398      CASE ( 0 ) 
    399          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    400          CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
    401          CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
    402          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
     399         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     400         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 ) 
     401         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea ) 
     402         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    403403         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    404404         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    405405      CASE ( 1 ) 
    406          CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
    407          CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
     406         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     407         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe ) 
    408408         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    409409      END SELECT 
    … …  
    415415      CASE ( -1 ) 
    416416         DO jl = 1, jpreci 
    417             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
     417            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    418418         END DO 
    419419      CASE ( 0 )  
    420420         DO jl = 1, jpreci 
    421             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
    422             ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 
     421            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     422            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    423423         END DO 
    424424      CASE ( 1 ) 
    425425         DO jl = 1, jpreci 
    426             ptab(jl      ,:,:) = zt3we(:,jl,:,2) 
     426            ptab(jl      ,:,:) = t3we(:,jl,:,2) 
    427427         END DO 
    428428      END SELECT 
    … …  
    436436         ijhom = nlcj-nrecj 
    437437         DO jl = 1, jprecj 
    438             zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    439             zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     438            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
     439            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
    440440         END DO 
    441441      ENDIF 
    … …  
    446446      SELECT CASE ( nbondj )      
    447447      CASE ( -1 ) 
    448          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
    449          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
     448         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     449         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
    450450         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    451451      CASE ( 0 ) 
    452          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    453          CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
    454          CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
    455          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
     452         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     453         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     454         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono ) 
     455         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    456456         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    457457         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    458458      CASE ( 1 )  
    459          CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
    460          CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
     459         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     460         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso ) 
    461461         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    462462      END SELECT 
    … …  
    468468      CASE ( -1 ) 
    469469         DO jl = 1, jprecj 
    470             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
     470            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    471471         END DO 
    472472      CASE ( 0 )  
    473473         DO jl = 1, jprecj 
    474             ptab(:,jl      ,:) = zt3sn(:,jl,:,2) 
    475             ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2) 
     474            ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
     475            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    476476         END DO 
    477477      CASE ( 1 ) 
    478478         DO jl = 1, jprecj 
    479             ptab(:,jl,:) = zt3sn(:,jl,:,2) 
     479            ptab(:,jl,:) = t3sn(:,jl,:,2) 
    480480         END DO 
    481481      END SELECT 
    … …  
    494494      ENDIF 
    495495      ! 
    496       DEALLOCATE( zt3ns   , zt3sn,  zt3ew   , zt3we ) 
     496      DEALLOCATE( t3ns   , t3sn,  t3ew   , t3we ) 
    497497   END SUBROUTINE mpp_lnk_3d 
    498498 
    … …  
    530530      REAL(wp) ::   zland 
    531531      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    532       REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   zt2ns, zt2sn   ! 2d for north-south & south-north 
    533       REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   zt2ew, zt2we   ! 2d for east-west & west-east 
    534  
    535       !!---------------------------------------------------------------------- 
    536       ALLOCATE( zt2ns(jpi,jprecj    ,2)   , zt2sn(jpi,jprecj    ,2)   ,   & 
    537          &      zt2ew(jpj,jpreci    ,2)   , zt2we(jpj,jpreci    ,2)) 
     532      REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   t2ns, t2sn   ! 2d for north-south & south-north 
     533      REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   t2ew, t2we   ! 2d for east-west & west-east 
     534 
     535      !!---------------------------------------------------------------------- 
     536      ALLOCATE( t2ns(jpi,jprecj    ,2)   , t2sn(jpi,jprecj    ,2)   ,   & 
     537         &      t2ew(jpj,jpreci    ,2)   , t2we(jpj,jpreci    ,2)) 
    538538       
    539539      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    … …  
    583583         iihom = nlci-nreci 
    584584         DO jl = 1, jpreci 
    585             zt2ew(:,jl,1) = pt2d(jpreci+jl,:) 
    586             zt2we(:,jl,1) = pt2d(iihom +jl,:) 
     585            t2ew(:,jl,1) = pt2d(jpreci+jl,:) 
     586            t2we(:,jl,1) = pt2d(iihom +jl,:) 
    587587         END DO 
    588588      END SELECT 
    … …  
    593593      SELECT CASE ( nbondi ) 
    594594      CASE ( -1 ) 
    595          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    596          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
     595         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     596         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    597597         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    598598      CASE ( 0 ) 
    599          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    600          CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    601          CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    602          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
     599         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     600         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     601         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     602         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    603603         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    604604         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    605605      CASE ( 1 ) 
    606          CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    607          CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
     606         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     607         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    608608         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    609609      END SELECT 
    … …  
    615615      CASE ( -1 ) 
    616616         DO jl = 1, jpreci 
    617             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
     617            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
    618618         END DO 
    619619      CASE ( 0 ) 
    620620         DO jl = 1, jpreci 
    621             pt2d(jl      ,:) = zt2we(:,jl,2) 
    622             pt2d(iihom+jl,:) = zt2ew(:,jl,2) 
     621            pt2d(jl      ,:) = t2we(:,jl,2) 
     622            pt2d(iihom+jl,:) = t2ew(:,jl,2) 
    623623         END DO 
    624624      CASE ( 1 ) 
    625625         DO jl = 1, jpreci 
    626             pt2d(jl      ,:) = zt2we(:,jl,2) 
     626            pt2d(jl      ,:) = t2we(:,jl,2) 
    627627         END DO 
    628628      END SELECT 
    … …  
    636636         ijhom = nlcj-nrecj 
    637637         DO jl = 1, jprecj 
    638             zt2sn(:,jl,1) = pt2d(:,ijhom +jl) 
    639             zt2ns(:,jl,1) = pt2d(:,jprecj+jl) 
     638            t2sn(:,jl,1) = pt2d(:,ijhom +jl) 
     639            t2ns(:,jl,1) = pt2d(:,jprecj+jl) 
    640640         END DO 
    641641      ENDIF 
    … …  
    646646      SELECT CASE ( nbondj ) 
    647647      CASE ( -1 ) 
    648          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    649          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
     648         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     649         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    650650         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    651651      CASE ( 0 ) 
    652          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    653          CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    654          CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    655          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
     652         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     653         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     654         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     655         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    656656         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    657657         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    658658      CASE ( 1 ) 
    659          CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    660          CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
     659         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     660         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    661661         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    662662      END SELECT 
    … …  
    668668      CASE ( -1 ) 
    669669         DO jl = 1, jprecj 
    670             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
     670            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
    671671         END DO 
    672672      CASE ( 0 ) 
    673673         DO jl = 1, jprecj 
    674             pt2d(:,jl      ) = zt2sn(:,jl,2) 
    675             pt2d(:,ijhom+jl) = zt2ns(:,jl,2) 
     674            pt2d(:,jl      ) = t2sn(:,jl,2) 
     675            pt2d(:,ijhom+jl) = t2ns(:,jl,2) 
    676676         END DO 
    677677      CASE ( 1 )  
    678678         DO jl = 1, jprecj 
    679             pt2d(:,jl      ) = zt2sn(:,jl,2) 
     679            pt2d(:,jl      ) = t2sn(:,jl,2) 
    680680         END DO 
    681681      END SELECT 
    … …  
    694694      ENDIF 
    695695      ! 
    696       DEALLOCATE( zt2ns   , zt2sn   , zt2ew   , zt2we) 
     696      DEALLOCATE( t2ns   , t2sn   , t2ew   , t2we) 
    697697   END SUBROUTINE mpp_lnk_2d 
    698698 
    … …  
    729729      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    730730      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    731  
    732       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north 
    733       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east 
    734  
    735       !!---------------------------------------------------------------------- 
    736       ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) ,    & 
    737          &      zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 
     731      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   t4ns, t4sn   ! 2 x 3d for north-south & south-north 
     732      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   t4ew, t4we   ! 2 x 3d for east-west & west-east 
     733 
     734      !!---------------------------------------------------------------------- 
     735      ALLOCATE(t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) ,    & 
     736         &     t4ew(jpj,jpreci,jpk,2,2) , t4we(jpj,jpreci,jpk,2,2)) 
    738737 
    739738 
    … …  
    770769         iihom = nlci-nreci 
    771770         DO jl = 1, jpreci 
    772             zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 
    773             zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 
    774             zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 
    775             zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 
     771            t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:) 
     772            t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:) 
     773            t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:) 
     774            t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:) 
    776775         END DO 
    777776      END SELECT 
    … …  
    782781      SELECT CASE ( nbondi )  
    783782      CASE ( -1 ) 
    784          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
    785          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
     783         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 ) 
     784         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
    786785         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    787786      CASE ( 0 ) 
    788          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    789          CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
    790          CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea ) 
    791          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
     787         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
     788         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 ) 
     789         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea ) 
     790         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    792791         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    793792         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    794793      CASE ( 1 ) 
    795          CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
    796          CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe ) 
     794         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 ) 
     795         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe ) 
    797796         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    798797      END SELECT 
    … …  
    804803      CASE ( -1 ) 
    805804         DO jl = 1, jpreci 
    806             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    807             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
     805            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 
     806            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 
    808807         END DO 
    809808      CASE ( 0 )  
    810809         DO jl = 1, jpreci 
    811             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    812             ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2) 
    813             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
    814             ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2) 
     810            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2) 
     811            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2) 
     812            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2) 
     813            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2) 
    815814         END DO 
    816815      CASE ( 1 ) 
    817816         DO jl = 1, jpreci 
    818             ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2) 
    819             ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2) 
     817            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2) 
     818            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2) 
    820819         END DO 
    821820      END SELECT 
    … …  
    829828         ijhom = nlcj - nrecj 
    830829         DO jl = 1, jprecj 
    831             zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 
    832             zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 
    833             zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 
    834             zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 
     830            t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:) 
     831            t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:) 
     832            t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:) 
     833            t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:) 
    835834         END DO 
    836835      ENDIF 
    … …  
    841840      SELECT CASE ( nbondj )      
    842841      CASE ( -1 ) 
    843          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
    844          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
     842         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 ) 
     843         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
    845844         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    846845      CASE ( 0 ) 
    847          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    848          CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
    849          CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono ) 
    850          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
     846         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
     847         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 ) 
     848         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono ) 
     849         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    851850         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    852851         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    853852      CASE ( 1 )  
    854          CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
    855          CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso ) 
     853         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 ) 
     854         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso ) 
    856855         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    857856      END SELECT 
    … …  
    863862      CASE ( -1 ) 
    864863         DO jl = 1, jprecj 
    865             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    866             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
     864            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2) 
     865            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 
    867866         END DO 
    868867      CASE ( 0 )  
    869868         DO jl = 1, jprecj 
    870             ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2) 
    871             ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2) 
    872             ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2) 
    873             ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2) 
     869            ptab1(:,jl      ,:) = t4sn(:,jl,:,1,2) 
     870            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2) 
     871            ptab2(:,jl      ,:) = t4sn(:,jl,:,2,2) 
     872            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2) 
    874873         END DO 
    875874      CASE ( 1 ) 
    876875         DO jl = 1, jprecj 
    877             ptab1(:,jl,:) = zt4sn(:,jl,:,1,2) 
    878             ptab2(:,jl,:) = zt4sn(:,jl,:,2,2) 
     876            ptab1(:,jl,:) = t4sn(:,jl,:,1,2) 
     877            ptab2(:,jl,:) = t4sn(:,jl,:,2,2) 
    879878         END DO 
    880879      END SELECT 
    … …  
    896895      ENDIF 
    897896      ! 
    898       DEALLOCATE(zt4ns , zt4sn , zt4ew , zt4we) 
    899       ! 
     897      DEALLOCATE(t4ns , t4sn , t4ew , t4we) 
    900898   END SUBROUTINE mpp_lnk_3d_gather 
    901899 
    … …  
    932930      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    933931      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    934       REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   ztr2ns, ztr2sn ! 2d for north-south & south-north + extra outer halo 
    935       REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   ztr2ew, ztr2we ! 2d for east-west   & west-east   + extra outer halo 
    936  
    937       !!---------------------------------------------------------------------- 
    938       ALLOCATE( ztr2ns(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     & 
    939          &      ztr2sn(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     & 
    940          &      ztr2ew(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ,                                                     & 
    941          &      ztr2we(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2)) 
     932      REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo 
     933      REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   tr2ew, tr2we ! 2d for east-west   & west-east   + extra outer halo 
     934 
     935      !!---------------------------------------------------------------------- 
     936      ALLOCATE( tr2ns(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     & 
     937         &      tr2sn(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     & 
     938         &      tr2ew(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ,                                                     & 
     939         &      tr2we(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2)) 
    942940          
    943941      ipreci = jpreci + jpr2di      ! take into account outer extra 2D overlap area 
    … …  
    984982         iihom = nlci-nreci-jpr2di 
    985983         DO jl = 1, ipreci 
    986             ztr2ew(:,jl,1) = pt2d(jpreci+jl,:) 
    987             ztr2we(:,jl,1) = pt2d(iihom +jl,:) 
     984            tr2ew(:,jl,1) = pt2d(jpreci+jl,:) 
     985            tr2we(:,jl,1) = pt2d(iihom +jl,:) 
    988986         END DO 
    989987      END SELECT 
    … …  
    994992      SELECT CASE ( nbondi ) 
    995993      CASE ( -1 ) 
    996          CALL mppsend( 2, ztr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 
    997          CALL mpprecv( 1, ztr2ew(1-jpr2dj,1,2), imigr, noea ) 
     994         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 ) 
     995         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
    998996         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    999997      CASE ( 0 ) 
    1000          CALL mppsend( 1, ztr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    1001          CALL mppsend( 2, ztr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 ) 
    1002          CALL mpprecv( 1, ztr2ew(1-jpr2dj,1,2), imigr, noea ) 
    1003          CALL mpprecv( 2, ztr2we(1-jpr2dj,1,2), imigr, nowe ) 
     998         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
     999         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 ) 
     1000         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea ) 
     1001         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    10041002         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10051003         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    10061004      CASE ( 1 ) 
    1007          CALL mppsend( 1, ztr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
    1008          CALL mpprecv( 2, ztr2we(1-jpr2dj,1,2), imigr, nowe ) 
     1005         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 ) 
     1006         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe ) 
    10091007         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10101008      END SELECT 
    … …  
    10161014      CASE ( -1 ) 
    10171015         DO jl = 1, ipreci 
    1018             pt2d(iihom+jl,:) = ztr2ew(:,jl,2) 
     1016            pt2d(iihom+jl,:) = tr2ew(:,jl,2) 
    10191017         END DO 
    10201018      CASE ( 0 ) 
    10211019         DO jl = 1, ipreci 
    1022             pt2d(jl-jpr2di,:) = ztr2we(:,jl,2) 
    1023             pt2d( iihom+jl,:) = ztr2ew(:,jl,2) 
     1020            pt2d(jl-jpr2di,:) = tr2we(:,jl,2) 
     1021            pt2d( iihom+jl,:) = tr2ew(:,jl,2) 
    10241022         END DO 
    10251023      CASE ( 1 ) 
    10261024         DO jl = 1, ipreci 
    1027             pt2d(jl-jpr2di,:) = ztr2we(:,jl,2) 
     1025            pt2d(jl-jpr2di,:) = tr2we(:,jl,2) 
    10281026         END DO 
    10291027      END SELECT 
    … …  
    10371035         ijhom = nlcj-nrecj-jpr2dj 
    10381036         DO jl = 1, iprecj 
    1039             ztr2sn(:,jl,1) = pt2d(:,ijhom +jl) 
    1040             ztr2ns(:,jl,1) = pt2d(:,jprecj+jl) 
     1037            tr2sn(:,jl,1) = pt2d(:,ijhom +jl) 
     1038            tr2ns(:,jl,1) = pt2d(:,jprecj+jl) 
    10411039         END DO 
    10421040      ENDIF 
    … …  
    10471045      SELECT CASE ( nbondj ) 
    10481046      CASE ( -1 ) 
    1049          CALL mppsend( 4, ztr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 ) 
    1050          CALL mpprecv( 3, ztr2ns(1-jpr2di,1,2), imigr, nono ) 
     1047         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 ) 
     1048         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
    10511049         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10521050      CASE ( 0 ) 
    1053          CALL mppsend( 3, ztr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    1054          CALL mppsend( 4, ztr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 ) 
    1055          CALL mpprecv( 3, ztr2ns(1-jpr2di,1,2), imigr, nono ) 
    1056          CALL mpprecv( 4, ztr2sn(1-jpr2di,1,2), imigr, noso ) 
     1051         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
     1052         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 ) 
     1053         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono ) 
     1054         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    10571055         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10581056         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    10591057      CASE ( 1 ) 
    1060          CALL mppsend( 3, ztr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
    1061          CALL mpprecv( 4, ztr2sn(1-jpr2di,1,2), imigr, noso ) 
     1058         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 ) 
     1059         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso ) 
    10621060         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    10631061      END SELECT 
    … …  
    10691067      CASE ( -1 ) 
    10701068         DO jl = 1, iprecj 
    1071             pt2d(:,ijhom+jl) = ztr2ns(:,jl,2) 
     1069            pt2d(:,ijhom+jl) = tr2ns(:,jl,2) 
    10721070         END DO 
    10731071      CASE ( 0 ) 
    10741072         DO jl = 1, iprecj 
    1075             pt2d(:,jl-jpr2dj) = ztr2sn(:,jl,2) 
    1076             pt2d(:,ijhom+jl ) = ztr2ns(:,jl,2) 
     1073            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2) 
     1074            pt2d(:,ijhom+jl ) = tr2ns(:,jl,2) 
    10771075         END DO 
    10781076      CASE ( 1 )  
    10791077         DO jl = 1, iprecj 
    1080             pt2d(:,jl-jpr2dj) = ztr2sn(:,jl,2) 
     1078            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2) 
    10811079         END DO 
    10821080      END SELECT 
    1083       DEALLOCATE( ztr2ns , ztr2sn , ztr2ew , ztr2we) 
     1081      DEALLOCATE( tr2ns , tr2sn , tr2ew , tr2we) 
    10841082   END SUBROUTINE mpp_lnk_2d_e 
    10851083 
    … …  
    17511749      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend 
    17521750      REAL(wp), POINTER, DIMENSION(:,:) ::   ztab   ! temporary workspace 
    1753       REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   zt2ns, zt2sn   ! 2d for north-south & south-north 
    1754       REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   zt2ew, zt2we   ! 2d for east-west & west-east 
    1755  
    1756       !!---------------------------------------------------------------------- 
    1757       ALLOCATE( zt2ns(jpi,jprecj    ,2)   , zt2sn(jpi,jprecj    ,2)   ,   & 
    1758          &      zt2ew(jpj,jpreci    ,2)   , zt2we(jpj,jpreci    ,2)) 
     1751      REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   t2ns, t2sn   ! 2d for north-south & south-north 
     1752      REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE ::   t2ew, t2we   ! 2d for east-west & west-east 
     1753 
     1754      !!---------------------------------------------------------------------- 
     1755      ALLOCATE( t2ns(jpi,jprecj    ,2)   , t2sn(jpi,jprecj    ,2)   ,   & 
     1756         &      t2ew(jpj,jpreci    ,2)   , t2we(jpj,jpreci    ,2)) 
    17591757 
    17601758 
    … …  
    18111809            iihom = nlci-nreci 
    18121810            DO jl = 1, jpreci 
    1813                zt2ew(:,jl,1) = ztab(jpreci+jl,:) 
    1814                zt2we(:,jl,1) = ztab(iihom +jl,:) 
     1811               t2ew(:,jl,1) = ztab(jpreci+jl,:) 
     1812               t2we(:,jl,1) = ztab(iihom +jl,:) 
    18151813            END DO 
    18161814         ENDIF 
    … …  
    18201818         ! 
    18211819         IF( nbondi == -1 ) THEN 
    1822             CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
    1823             CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
     1820            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 ) 
     1821            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
    18241822            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18251823         ELSEIF( nbondi == 0 ) THEN 
    1826             CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1827             CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
    1828             CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
    1829             CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
     1824            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1825            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 ) 
     1826            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea ) 
     1827            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    18301828            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18311829            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    18321830         ELSEIF( nbondi == 1 ) THEN 
    1833             CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
    1834             CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
     1831            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1832            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe ) 
    18351833            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18361834         ENDIF 
    … …  
    18411839         IF( nbondi == 0 .OR. nbondi == 1 ) THEN 
    18421840            DO jl = 1, jpreci 
    1843                ztab(jl,:) = zt2we(:,jl,2) 
     1841               ztab(jl,:) = t2we(:,jl,2) 
    18441842            END DO 
    18451843         ENDIF 
    18461844         IF( nbondi == -1 .OR. nbondi == 0 ) THEN 
    18471845            DO jl = 1, jpreci 
    1848                ztab(iihom+jl,:) = zt2ew(:,jl,2) 
     1846               ztab(iihom+jl,:) = t2ew(:,jl,2) 
    18491847            END DO 
    18501848         ENDIF 
    … …  
    18571855            ijhom = nlcj-nrecj 
    18581856            DO jl = 1, jprecj 
    1859                zt2sn(:,jl,1) = ztab(:,ijhom +jl) 
    1860                zt2ns(:,jl,1) = ztab(:,jprecj+jl) 
     1857               t2sn(:,jl,1) = ztab(:,ijhom +jl) 
     1858               t2ns(:,jl,1) = ztab(:,jprecj+jl) 
    18611859            END DO 
    18621860         ENDIF 
    … …  
    18661864         ! 
    18671865         IF( nbondj == -1 ) THEN 
    1868             CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
    1869             CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
     1866            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 ) 
     1867            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
    18701868            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18711869         ELSEIF( nbondj == 0 ) THEN 
    1872             CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1873             CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
    1874             CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
    1875             CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
     1870            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1871            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 ) 
     1872            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono ) 
     1873            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso ) 
    18761874            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18771875            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err ) 
    18781876         ELSEIF( nbondj == 1 ) THEN 
    1879             CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
    1880             CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso) 
     1877            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 ) 
     1878            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso) 
    18811879            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err ) 
    18821880         ENDIF 
    … …  
    18861884         IF( nbondj == 0 .OR. nbondj == 1 ) THEN 
    18871885            DO jl = 1, jprecj 
    1888                ztab(:,jl) = zt2sn(:,jl,2) 
     1886               ztab(:,jl) = t2sn(:,jl,2) 
    18891887            END DO 
    18901888         ENDIF 
    18911889         IF( nbondj == 0 .OR. nbondj == -1 ) THEN 
    18921890            DO jl = 1, jprecj 
    1893                ztab(:,ijhom+jl) = zt2ns(:,jl,2) 
     1891               ztab(:,ijhom+jl) = t2ns(:,jl,2) 
    18941892            END DO 
    18951893         ENDIF 
    … …  
    19101908      END DO 
    19111909      ! 
    1912       DEALLOCATE( zt2ns   , zt2sn   , zt2ew   , zt2we) 
    1913  
     1910      DEALLOCATE( t2ns   , t2sn   , t2ew   , t2we) 
    19141911      CALL wrk_dealloc( jpi,jpj, ztab ) 
    19151912      ! 

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90

    r3860 r3895  
    2828                   jpj_full                     !: 2nd dimension of local parent grid domain 
    2929 
    30       INTEGER  ::  nistart, njstart 
    31       INTEGER  ::  niend  , njend 
     30      INTEGER  ::  nistr , njstr 
     31      INTEGER  ::  niend , njend 
    3232 
    3333      INTEGER  ::  jpi_crsm1, jpj_crsm1         !: loop indices       

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdiawri.F90

    r3860 r3895  
    44   !! Ocean diagnostics :  write ocean output files 
    55   !!===================================================================== 
    6    !! History :  OPA  ! 1991-03  (M.-A. Foujols)  Original code 
    7    !!            4.0  ! 1991-11  (G. Madec) 
    8    !!                 ! 1992-06  (M. Imbard)  correction restart file 
    9    !!                 ! 1992-07  (M. Imbard)  split into diawri and rstwri 
    10    !!                 ! 1993-03  (M. Imbard)  suppress writibm 
    11    !!                 ! 1998-01  (C. Levy)  NETCDF format using ioipsl INTERFACE 
    12    !!                 ! 1999-02  (E. Guilyardi)  name of netCDF files + variables 
    13    !!            8.2  ! 2000-06  (M. Imbard)  Original code (diabort.F) 
    14    !!   NEMO     1.0  ! 2002-06  (A.Bozec, E. Durand)  Original code (diainit.F) 
    15    !!             -   ! 2002-09  (G. Madec)  F90: Free form and module 
    16    !!             -   ! 2002-12  (G. Madec)  merge of diabort and diainit, F90 
    17    !!                 ! 2005-11  (V. Garnier) Surface pressure gradient organization 
    18    !!            3.2  ! 2008-11  (B. Lemaire) creation from old diawri 
    19    !!                 ! 2012-07  (J. Simeon, G. Madec, C. Ethe, C. Calone) Modified for coarsened output 
     6   !!   2012-07  (J. Simeon, C. Calone, G. Madec, C. Ethe) 
    207   !!---------------------------------------------------------------------- 
    218 
    … …  
    131118      !  Temperature 
    132119      zt(:,:,:) = tsn(:,:,:,jp_tem)  ;      zt_crs(:,:,:) = 0._wp 
    133       CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='VOL', p_cmask=tmask_crs, p_ptmask=tmask, & 
    134          &         p_pfield3d_1=zfse3t, p_pfield3d_2=zt, p_cfield3d=zt_crs ) 
     120      CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=zfse3t ) 
    135121      tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) 
    136122      CALL crs_iom_put( "toce_crs", pv_r3d=tsn_crs(:,:,:,jp_tem) )    ! temp 
    … …  
    138124 
    139125      !  Salinity 
    140       zt(:,:,:) = tsn(:,:,:,jp_sal)  ;      zt_crs(:,:,:) = 0._wp 
    141       CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='VOL', p_cmask=tmask_crs, p_ptmask=tmask, & 
    142          &         p_pfield3d_1=zfse3t, p_pfield3d_2=zt, p_cfield3d=zt_crs ) 
     126      zs(:,:,:) = tsn(:,:,:,jp_sal)  ;      zs_crs(:,:,:) = 0._wp 
     127      CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3t ) 
    143128      tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) 
    144129      CALL crs_iom_put( "soce_crs" , pv_r3d=tsn_crs(:,:,:,jp_sal) )    ! sal 
    … …  
    146131 
    147132      !  U-velocity 
    148       CALL crsfun( p_e1_e2=e2u, cd_type='U', psgn=-1.0, p_pmask=umask, & 
    149          &         p_fse3=zfse3u, p_pfield=un, p_surf_crs=crs_surfu_wgt, p_cfield3d=un_crs ) 
     133      CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk ) 
    150134      CALL crs_iom_put( "uoce_crs"  , pv_r3d=un_crs  )   ! i-current  
    151135      ! 
    … …  
    159143         END DO 
    160144      END DO 
    161       CALL crsfun( p_e1_e2=e2u, cd_type='U', psgn=-1.0, p_pmask=umask, & 
    162          &         p_fse3=zfse3u, p_pfield=zt,  p_cfield3d=zt_crs ) 
     145      CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk ) 
    163146      CALL crs_iom_put( "uocet_crs" , pv_r3d=zt_crs )   ! uT 
    164       CALL crsfun( p_e1_e2=e2u, cd_type='U', psgn=-1.0, p_pmask=umask, & 
    165          &         p_fse3=zfse3u, p_pfield=zs,  p_cfield3d=zs_crs ) 
     147      CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk ) 
    166148      CALL crs_iom_put( "uoces_crs" , pv_r3d=zs_crs )   ! uS 
    167149 
    168150 
    169151      !  V-velocity 
    170       CALL crsfun( p_e1_e2=e1v, cd_type='V', psgn=-1.0, p_pmask=vmask, & 
    171          &         p_fse3=zfse3v, p_pfield=vn, p_surf_crs=crs_surfv_wgt, p_cfield3d=vn_crs ) 
     152      CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk ) 
    172153      CALL crs_iom_put( "voce_crs"  , pv_r3d=vn_crs  )   ! v-current  
    173154      !                                                                                  
    … …  
    181162         END DO 
    182163      END DO 
    183       CALL crsfun( p_e1_e2=e1v, cd_type='V', psgn=-1.0, p_pmask=vmask, & 
    184          &         p_fse3=zfse3v, p_pfield=zt, p_cfield3d=zt_crs ) 
     164      CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk ) 
    185165      CALL crs_iom_put( "vocet_crs" , pv_r3d=zt_crs )   ! vT 
    186166 
    187       CALL crsfun( p_e1_e2=e1v, cd_type='V', psgn=-1.0, p_pmask=vmask, & 
    188          &         p_fse3=zfse3v, p_pfield=zs, p_cfield3d=zs_crs ) 
     167      CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk ) 
    189168      CALL crs_iom_put( "voces_crs" , pv_r3d=zs_crs )   ! vS 
    190169       
    191170      !  Kinetic energy 
    192       CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='VOL', p_cmask=tmask_crs, p_ptmask=tmask, & 
    193          &         p_pfield3d_1=zfse3t, p_pfield3d_2=rke, p_cfield3d=rke_crs ) 
    194       rke_crs(:,:,:) = rke_crs(:,:,:) * tmask_crs(:,:,:) 
     171      CALL crs_dom_ope( rke, 'VOL', 'T', tmask, rke_crs, p_e12=e1e2t, p_e3=zfse3t ) 
    195172      CALL crs_iom_put( "eken_crs", pv_r3d=rke_crs ) 
    196173    
    197       ! 
    198  
    199  
    200174      !  Horizontal divergence ( following OPA_SRC/DYN/divcur.F90 )  
    201175      DO jk = 1, jpkm1 
    … …  
    213187         ENDDO 
    214188      ENDDO 
    215       CALL crs_lbc_lnk( hdivn_crs,'T', 1.0     ) 
     189      CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0  ) 
    216190      CALL crs_iom_put( "hdiv_crs", pv_r3d=hdivn_crs )   
    217191 
    218192       
    219193      !  Sea-surface Height  
    220       CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='ARE', p_cmask=tmask_crs, p_ptmask=tmask, & 
    221            &       p_pfield2d=sshn, p_cfield2d=sshn_crs ) 
     194      CALL crs_dom_ope( sshn, 'VOL', 'T', tmask, sshn_crs, p_e12=e1e2t, p_e3=zfse3t ) 
    222195      CALL crs_iom_put( "ssh_crs" , pv_r2d=sshn_crs  )   ! ssh output  
    223196 
    224197      !  W-velocity 
    225       CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='ARE', p_cmask=tmask_crs, p_ptmask=tmask, & 
    226          &         p_pfield3d_2=wn, p_cfield3d=wn_crs ) 
    227       CALL crs_iom_put( "woce_crs"  , pv_r3d=wn_crs  )   ! i-current  
    228        
    229  
     198      CALL crs_dom_ope( wn, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=zfse3w ) 
     199      CALL crs_iom_put( "woce_crs" , pv_r3d=wn_crs  )   ! i-current  
     200       
    230201 
    231202      !  Clean-up 
    232        
    233203      CALL wrk_dealloc( jpi, jpj, jpk, zfse3t, zfse3w ) 
    234204      CALL wrk_dealloc( jpi, jpj, jpk, zfse3u, zfse3v ) 

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90

    r3864 r3895  
    2828   !!               Climate Dynamics, 14:101-116. 
    2929   !!  History:  
    30    !!       Original.   May 2012.  (J. Simeon, G. Madec, C. Ethe, C. Calone) 
     30   !!       Original.   May 2012.  (J. Simeon, C. Calone, G. Madec, C. Ethe) 
    3131   !!=================================================================== 
    3232 
    … …  
    4343   PRIVATE  
    4444 
    45    PUBLIC crsfun, crsfun_wgt 
    46    PUBLIC crs_dom_e3_max, crs_dom_sfc, crs_dom_msk, crs_dom_def, crs_dom_hgr, crs_dom_coordinates, crs_dom_bat 
    47  
    48    INTERFACE crsfun 
    49       MODULE PROCEDURE crsfun_UV, crsfun_TW 
     45   PUBLIC crs_dom_ope 
     46   PUBLIC crs_dom_e3_max, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates 
     47   PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat 
     48 
     49   INTERFACE crs_dom_ope 
     50      MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d 
    5051   END INTERFACE 
    5152 
    … …  
    5859   SUBROUTINE crs_dom_msk 
    5960       
    60       INTEGER  ::  ji, jj, jk, ijpk                   ! dummy loop indices 
    61       INTEGER  :: ijie,ijis,ijje,ijjs 
    62       REAL(wp) ::   zmask 
     61      INTEGER  ::  ji, jj, jk                   ! dummy loop indices 
     62      INTEGER  ::  ijie,ijis,ijje,ijjs 
     63      REAL(wp) ::  zmask 
    6364       
    6465      ! Initialize 
    … …  
    6970      fmask_crs(:,:,:) = 0.0 
    7071       
    71       DO jk = 1, jpk 
     72      DO jk = 1, jpkm1 
    7273         DO ji = 2, nlei_crs   
    7374            ijie = mie_crs(ji) 
    7475            ijis = mis_crs(ji) 
    75             DO jj = njstart, njend  
     76            DO jj = nldj_crs, nlej_crs  
    7677               ijje = mje_crs(jj)  
    7778               ijjs = mjs_crs(jj)  
    7879                                  
    79                zmask = 0 
     80               zmask = 0.0 
    8081               zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) )  
    81                IF ( zmask > 0 ) tmask_crs(ji,jj,jk) = 1 
     82               IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 
    8283                
    83                zmask = 0 
     84               zmask = 0.0 
    8485               zmask = SUM( vmask(ijis:ijie,ijje     ,jk) )   
    85                IF ( zmask > 0 ) vmask_crs(ji,jj,jk) = 1 
     86               IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 
    8687                
    87                zmask = 0 
     88               zmask = 0.0 
    8889               zmask = SUM( umask(ijie     ,ijjs:ijje,jk) )   
    89                IF ( zmask > 0 ) umask_crs(ji,jj,jk) = 1 
     90               IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 
    9091                
    9192               fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)   
    … …  
    9596      ENDDO 
    9697      ! 
    97       CALL crs_lbc_lnk( tmask_crs(:,:,:), 'T', psgn = 1.0 ) 
    98       CALL crs_lbc_lnk( vmask_crs(:,:,:), 'V', psgn = 1.0 ) 
    99       CALL crs_lbc_lnk( umask_crs(:,:,:), 'U', psgn = 1.0 ) 
    100       CALL crs_lbc_lnk( fmask_crs(:,:,:), 'F', psgn = 1.0 ) 
     98      CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) 
     99      CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) 
     100      CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) 
     101      CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) 
    101102      ! 
    102103   END SUBROUTINE crs_dom_msk 
    103104 
    104    SUBROUTINE crs_dom_coordinates( p_pgphi, p_pglam, cd_type, p_cgphi, p_cglam ) 
     105   SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs ) 
    105106      !!---------------------------------------------------------------- 
    106107      !!               *** SUBROUTINE crs_coordinates *** 
    … …  
    116117      !!               the central f-corner. 
    117118      !! 
    118       !! ** Input   :  p_pgphi = parent grid gphi[t|u|v|f] 
    119       !!               p_pglam = parent grid glam[t|u|v|f] 
     119      !! ** Input   :  p_gphi = parent grid gphi[t|u|v|f] 
     120      !!               p_glam = parent grid glam[t|u|v|f] 
    120121      !!               cd_type  = grid type (T,U,V,F) 
    121       !! ** Output  :  p_cgphi = coarse grid gphi[t|u|v|f] 
    122       !!               p_cglam = coarse grid glam[t|u|v|f] 
     122      !! ** Output  :  p_gphi_crs = coarse grid gphi[t|u|v|f] 
     123      !!               p_glam_crs = coarse grid glam[t|u|v|f] 
    123124      !!               
    124125      !! History. 1 Jun. 
    125126      !!---------------------------------------------------------------- 
    126127      !! Arguments 
    127       REAL(wp), DIMENSION(jpi,jpj), INTENT(in)  :: p_pgphi  ! Parent grid latitude 
    128       REAL(wp), DIMENSION(jpi,jpj), INTENT(in)  :: p_pglam  ! Parent grid longitude 
    129       CHARACTER(len=1),             INTENT(in)  :: cd_type   ! grid type (T,U,V,F)  
    130       REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_cgphi  ! Coarse grid latitude 
    131       REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_cglam  ! Coarse grid longitude 
     128      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_gphi  ! Parent grid latitude 
     129      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_glam  ! Parent grid longitude 
     130      CHARACTER(len=1),                     INTENT(in)  :: cd_type   ! grid type (T,U,V,F)  
     131      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs  ! Coarse grid latitude 
     132      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs  ! Coarse grid longitude 
    132133 
    133134      !! Local variables 
    134       INTEGER ::  ji, jj, jk                   ! dummy loop indices 
    135       INTEGER :: ijie,ijis,ijje,ijjs,ijpk 
     135      INTEGER :: ji, jj, jk                   ! dummy loop indices 
     136      INTEGER :: ijis, ijjs 
    136137 
    137138   
    138       !! Initialize output fields 
    139       p_cgphi(:,:) = 0.e0 
    140       p_cglam(:,:) = 0.e0 
    141  
    142        DO ji = 2, nlei_crs 
    143  
    144          IF ( cd_type == 'T' .OR. cd_type == 'V' )  ijis = mis_crs(ji) + mxbinctr  
    145          IF ( cd_type == 'U' .OR. cd_type == 'F' )  ijis = mie_crs(ji) 
    146  
    147          DO jj = njstart, njend 
    148       
    149             IF ( cd_type == 'T' .OR. cd_type == 'U' ) ijjs = mjs_crs(jj) + mybinctr                   
    150             IF ( cd_type == 'V' .OR. cd_type == 'F' ) ijjs = mje_crs(jj) 
    151  
    152             p_cgphi(ji,jj) = p_pgphi(ijis,ijjs) 
    153             p_cglam(ji,jj) = p_pglam(ijis,ijjs) 
    154               
    155          ENDDO 
    156  
    157       ENDDO 
    158  
    159  
    160        ! Retroactively add back the boundary halo cells. 
    161  
    162          CALL crs_lbc_lnk( p_cgphi(:,:),cd_type,1.0 ) 
    163          CALL crs_lbc_lnk( p_cglam(:,:),cd_type,1.0 ) 
     139      SELECT CASE ( cd_type ) 
     140         CASE ( 'T' ) 
     141            DO jj =  nldj_crs, nlej_crs 
     142               ijjs = mjs_crs(jj) + mybinctr 
     143               DO ji = 2, nlei_crs 
     144                  ijis = mis_crs(ji) + mxbinctr  
     145                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
     146                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
     147               ENDDO 
     148            ENDDO 
     149         CASE ( 'U' ) 
     150            DO jj =  nldj_crs, nlej_crs 
     151               ijjs = mjs_crs(jj) + mybinctr                   
     152               DO ji = 2, nlei_crs 
     153                  ijis = mis_crs(ji) 
     154                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
     155                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
     156               ENDDO 
     157            ENDDO 
     158         CASE ( 'V' ) 
     159            DO jj =  nldj_crs, nlej_crs 
     160               ijjs = mjs_crs(jj) 
     161               DO ji = 2, nlei_crs 
     162                  ijis = mis_crs(ji) + mxbinctr  
     163                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
     164                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
     165               ENDDO 
     166            ENDDO 
     167         CASE ( 'F' ) 
     168            DO jj =  nldj_crs, nlej_crs 
     169               ijjs = mjs_crs(jj) 
     170               DO ji = 2, nlei_crs 
     171                  ijis = mis_crs(ji) 
     172                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs) 
     173                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs) 
     174               ENDDO 
     175            ENDDO 
     176      END SELECT 
     177 
     178      ! Retroactively add back the boundary halo cells. 
     179      CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 ) 
     180      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 ) 
    164181          
    165182      ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 
    166  
    167     DO ji = 2, nlei_crs 
    168  
    169          IF ( cd_type == 'T' .OR. cd_type == 'V' )  ijis = mis_crs(ji) + mxbinctr  
    170          IF ( cd_type == 'U' .OR. cd_type == 'F' )  ijis = mie_crs(ji) 
    171  
    172          p_cgphi(ji,1) = p_pgphi(ijis,1) 
    173          p_cglam(ji,1) = p_pglam(ijis,1) 
    174  
    175       ENDDO 
    176  
    177       ! Fill i=1, i=jpi at j=1 
    178       p_cgphi(1,1) = p_cgphi(jpi_crsm1,1) 
    179       p_cglam(1,1) = p_cglam(jpi_crsm1,1) 
    180       p_cgphi(jpi_crs,1) = p_cgphi(2,1) 
    181       p_cglam(jpi_crs,1) = p_cglam(2,1) 
    182       ! Fill upper-right corner i=1, j=jpj_crs 
    183   
     183      SELECT CASE ( cd_type ) 
     184         CASE ( 'T', 'V' ) 
     185            DO ji = 2, nlei_crs 
     186               ijis = mis_crs(ji) + mxbinctr  
     187               p_gphi_crs(ji,1) = p_gphi(ijis,1) 
     188               p_glam_crs(ji,1) = p_glam(ijis,1) 
     189            ENDDO 
     190         CASE ( 'U', 'F' ) 
     191            DO ji = 2, nlei_crs 
     192               ijis = mis_crs(ji)  
     193               p_gphi_crs(ji,1) = p_gphi(ijis,1) 
     194               p_glam_crs(ji,1) = p_glam(ijis,1) 
     195            ENDDO 
     196      END SELECT 
     197 
     198      !                                             ! Fill i=1, i=jpi at j=1 
     199      p_gphi_crs(1      ,1) = p_gphi(jpi_crsm1,1) 
     200      p_glam_crs(1      ,1) = p_glam(jpi_crsm1,1) 
     201      !                                             ! Fill upper-right corner i=1, j=jpj_crs 
     202      p_gphi_crs(jpi_crs,1) = p_gphi(2        ,1) 
     203      p_glam_crs(jpi_crs,1) = p_glam(2        ,1) 
     204      !                                             
    184205   END SUBROUTINE crs_dom_coordinates 
    185206 
    … …  
    211232 
    212233      !! Local variables 
    213       INTEGER                                 :: ji, jj, jk     ! dummy loop indices 
    214       INTEGER                                 :: ijie,ijis,ijje,ijjs,ijrs 
     234      INTEGER :: ji, jj, jk     ! dummy loop indices 
     235      INTEGER :: ijie,ijis,ijje,ijjs,ijrs 
    215236   
    216237      !!----------------------------------------------------------------   
    … …  
    221242            ijie = mie_crs(ji) 
    222243            ijis = mis_crs(ji) 
    223             DO jj = njstart, njend 
     244            DO jj = nldj_crs, nlej_crs 
    224245               ijje = mje_crs(jj)  
    225246               ijjs = mjs_crs(jj)                    
    … …  
    262283 
    263284 
    264    SUBROUTINE crsfun_wgt( cd_type, cd_op, p_pmask, p_e1, p_e2, p_fse3, & 
    265       &                   p_cfield2d_1, p_cfield2d_2, p_cfield3d_1, p_cfield3d_2 ) 
     285   SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs ) 
    266286      !!---------------------------------------------------------------- 
    267287      !!               *** SUBROUTINE crsfun_wgt *** 
    … …  
    304324      !!  
    305325      !!  Arguments 
    306       CHARACTER(len=1),                 INTENT(in) :: cd_type  ! grid type U,V  
    307       CHARACTER(len=3),                 INTENT(in) :: cd_op    ! operation sum or average 
    308       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_pmask  ! Parent grid U,V mask 
    309       REAL(wp), DIMENSION(jpi,jpj),     INTENT(in) :: p_e1     ! Parent grid U,V scale factors (e1) 
    310       REAL(wp), DIMENSION(jpi,jpj),     INTENT(in) :: p_e2     ! Parent grid U,V scale factors (e2) 
    311  
    312       REAL(wp), DIMENSION(:,:),   INTENT(out), OPTIONAL :: p_cfield2d_1 ! Coarse grid box 2D quantity 
    313       REAL(wp), DIMENSION(:,:),   INTENT(out), OPTIONAL :: p_cfield2d_2 ! Coarse grid box 2D quantity 
    314       REAL(wp), DIMENSION(:,:,:), INTENT(out), OPTIONAL :: p_cfield3d_1 ! Coarse grid box 3D quantity  
    315       REAL(wp), DIMENSION(:,:,:), INTENT(out), OPTIONAL :: p_cfield3d_2 ! Coarse grid box 3D quantity  
    316  
    317       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_fse3     ! Parent grid vertical level thickness (fse3u, fse3v) 
     326      CHARACTER(len=1),                         INTENT(in)  :: cd_type  ! grid type U,V  
     327      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)  :: p_mask  ! Parent grid U,V mask 
     328      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in)  :: p_e1     ! Parent grid U,V scale factors (e1) 
     329      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in)  :: p_e2     ! Parent grid U,V scale factors (e2) 
     330      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)  :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v) 
     331 
     332      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld1_crs ! Coarse grid box 3D quantity  
     333      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld2_crs ! Coarse grid box 3D quantity  
    318334 
    319335      !! Local variables 
    320       INTEGER                                 ::  ji, jj, jk, jii, jjj     ! dummy loop indices 
    321       INTEGER                                 :: ijie,ijis,ijje,ijjs,ijpk 
    322       REAL(wp)                                :: zdAm                      ! masked face area 
    323       REAL(wp), DIMENSION(:,:),   POINTER     :: ze1, ze2 
    324       REAL(wp), DIMENSION(:,:,:), POINTER     :: ze3        
    325       REAL(wp), DIMENSION(:,:),   POINTER     :: zcfield2d_1, zcfield2d_2 
    326       REAL(wp), DIMENSION(:,:,:), POINTER     :: zcfield3d_1, zcfield3d_2 
    327    
     336      REAL(wp)                                :: zdAm 
     337      INTEGER                                 :: ji, jj, jk       ! dummy loop indices 
     338      INTEGER                                 :: ii, ij, ijie,ijje 
     339 
     340      REAL(wp), DIMENSION(:,:,:), POINTER     :: zvol       
    328341      !!----------------------------------------------------------------   
    329       ! Initialize       
    330  
    331       ! Arrays, scalars initialization  
    332       CALL wrk_alloc(jpi    , jpj         , ze1, ze2 ) 
    333       CALL wrk_alloc(jpi    , jpj    , jpk, ze3 ) 
    334       CALL wrk_alloc(jpi_crs, jpj_crs,      zcfield2d_1,  zcfield2d_2 ) 
    335       CALL wrk_alloc(jpi_crs, jpj_crs, jpk, zcfield3d_1,  zcfield3d_2 ) 
    336  
    337       ze1(:,:) = 1.0 
    338       ze2(:,:) = 1.0 
    339       ze3(:,:,:) = 1.0 
    340       zcfield2d_1(:,:)  = 0.0 
    341       zcfield2d_2(:,:)  = 0.0 
    342       zcfield3d_1(:,:,:) = 0.0 
    343       zcfield3d_2(:,:,:) = 0.0 
    344      
    345       ijpk = jpk 
    346  
    347      ! Control of arguments 
    348       ze1(:,:) = p_e1(:,:) 
    349       ze2(:,:) = p_e2(:,:) 
    350  
    351       IF ( PRESENT(p_cfield2d_1) ) p_cfield2d_1(:,:) = 0.0 
    352       IF ( PRESENT(p_cfield2d_2) ) p_cfield2d_2(:,:) = 0.0 
    353       IF ( PRESENT(p_cfield3d_1) ) p_cfield3d_1(:,:,:) = 0.0 
    354       IF ( PRESENT(p_cfield3d_2) ) p_cfield3d_2(:,:,:) = 0.0 
    355  
    356       IF ( PRESENT(p_fse3) ) ze3(:,:,:) = p_fse3(:,:,:) 
    357  
    358  
    359           DO jk = 1, ijpk     
    360  
    361              zcfield2d_1(:,:) = 0.0 ; zcfield2d_2(:,:) = 0.0         
    362             DO ji = 2, nlei_crs 
    363                 ijie = mie_crs(ji) 
    364                 ijis = mis_crs(ji) 
    365  
    366  
    367                 DO jj = njstart, njend 
    368                    ijje = mje_crs(jj)  
    369                    ijjs = mjs_crs(jj)                    
    370                     
    371                    IF ( cd_op == 'POS' ) THEN      !cc 
    372                     
    373                       IF ( nn_factx == 3 .AND. nn_facty == 3) THEN 
    374                        
    375                          SELECT CASE ( cd_type ) 
    376                           
    377                             CASE ( 'T' ) 
    378  
    379                                SELECT CASE ( mje_crs(jj)-mjs_crs(jj) ) 
    380                                       
    381                                   CASE( 0, 1 )    ! Si à la frontière sud on a pas assez de maille de la grille mère 
    382                                        
    383                                      zcfield2d_1(ji,jj) = ze1(ijie-1,ijje  ) * nn_factx 
    384                                      zcfield2d_2(ji,jj) = ze2(ijie-1,ijje  ) * nn_facty 
    385                                         
    386                                   CASE DEFAULT 
    387342    
    388                                      zcfield2d_1(ji,jj) = ze1(ijie-1,ijje-1) * nn_factx 
    389                                      zcfield2d_2(ji,jj) = ze2(ijie-1,ijje-1) * nn_facty 
    390   
    391                                   END SELECT 
    392                               
    393                             CASE ( 'U' ) 
    394                              
    395                                SELECT CASE ( mje_crs(jj)-mjs_crs(jj) ) 
    396                                 
    397                                   CASE( 0, 1 )    ! Si à la frontière sud on a pas assez de maille de la grille mère 
    398                                    
    399                                      zcfield2d_1(ji,jj) = ze1(ijie  ,ijje  ) * nn_factx                             
    400                                      zcfield2d_2(ji,jj) = ze2(ijie  ,ijje  ) * nn_facty 
    401                                       
    402                                   CASE DEFAULT 
    403                                       
    404                                      zcfield2d_1(ji,jj) = ze1(ijie  ,ijje-1) * nn_factx                             
    405                                      zcfield2d_2(ji,jj) = ze2(ijie  ,ijje-1) * nn_facty 
    406                                       
    407                                END SELECT 
    408                                  
    409                             CASE ( 'V' ) 
    410  
    411                                zcfield2d_1(ji,jj) = ze1(ijie-1,ijje  ) * nn_factx 
    412                                zcfield2d_2(ji,jj) = ze2(ijie-1,ijje  ) * nn_facty 
    413                                                                
    414                             CASE ( 'F' ) 
    415  
    416                                zcfield2d_1(ji,jj) = ze1(ijie  ,ijje  ) * nn_factx                          
    417                                zcfield2d_2(ji,jj) = ze2(ijie  ,ijje  ) * nn_facty 
    418                                 
    419                          END SELECT 
    420                       ENDIF 
    421                    ENDIF                     
    422                     
    423  
    424                    IF ( cd_op == 'WGT' ) THEN 
    425  
    426                       zdAm = 0.0 
    427  
    428                       IF ( cd_type == 'V' ) THEN 
    429                          !  
    430                          DO jii = ijis, ijie 
    431                             zdAm = zdAm + ( ze1(jii,ijje) * ze3(jii,ijje,jk) * p_pmask(jii,ijje,jk) )  
    432                          ENDDO 
    433                          IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm  
    434      
    435                       ELSEIF ( cd_type == 'U') THEN 
    436                          DO jjj = ijjs, ijje 
    437                             zdAm = zdAm + ( ze2(ijie,jjj) * ze3(ijie,jjj,jk) * p_pmask(ijie,jjj,jk) ) 
    438                          ENDDO 
    439                          IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm  
    440  
    441                       ELSEIF ( cd_type == 'W' ) THEN 
    442                          DO jii = ijis, ijie 
    443                             DO jjj = ijjs, ijje 
    444                                zdAm = zdAm + ( ze1(jii,jjj) * ze2(jii,jjj) * p_pmask(jii,jjj,jk) ) 
    445                             ENDDO 
    446                          ENDDO 
    447                          IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm 
    448  
    449                       ELSEIF ( cd_type == 'T' ) THEN 
    450                          DO jii = ijis, ijie 
    451                             DO jjj = ijjs, ijje 
    452                                zdAm = zdAm + ( ze1(jii,jjj) * ze2(jii,jjj) * ze3(jii,jjj,jk) * p_pmask(jii,jjj,jk) ) 
    453                             ENDDO 
    454                          ENDDO 
    455                          IF ( zdAm /= 0 ) zcfield3d_1(ji,jj,jk) = zdAm 
    456  
    457                       ELSE 
    458    
    459                          ! jes. Add a stop? 
    460  
    461                       ENDIF 
    462  
    463                    ENDIF 
    464  
    465                    IF ( cd_op == 'VOL' ) THEN 
    466  
    467                       zdAm = 0.0 
    468  
    469                       IF ( cd_type == 'W' .OR. cd_type == 'T' ) THEN 
    470  
    471                          DO jii = ijis, ijie 
    472                             DO jjj = ijjs, ijje 
    473                                zcfield3d_1(ji,jj,jk) = zcfield3d_1(ji,jj,jk) + ( ze1(jii,jjj) * ze2(jii,jjj) * ze3(jii,jjj,jk) ) 
    474                                zdAm = zdAm + ( ze1(jii,jjj) * ze2(jii,jjj) * ze3(jii,jjj,jk) * p_pmask(jii,jjj,jk) ) 
    475                             ENDDO 
    476                          ENDDO 
    477                          IF ( zcfield3d_1(ji,jj,jk) /= 0 ) zcfield3d_2(ji,jj,jk) = zdAm / zcfield3d_1(ji,jj,jk) 
    478  
    479                       ELSE 
    480                           ! jes. add a stop? 
    481                       ENDIF 
    482  
    483                    ENDIF 
    484                                      
    485                 ENDDO 
    486              ENDDO 
    487  
    488           ENDDO 
    489  
    490 ! Retroactively add back the boundary halo cells. 
    491  
    492  
    493  
    494          ! Take care of the 2D arrays 
    495          IF ( cd_op == 'SUM' .OR.  cd_op == 'POS') THEN 
    496             IF ( PRESENT(p_cfield2d_1) ) THEN 
    497                p_cfield2d_1(:,:) = zcfield2d_1(:,:) 
    498                CALL crs_lbc_lnk( p_cfield2d_1(:,:),cd_type,1.0, pval=1.0) 
    499             ENDIF 
    500              
    501             IF ( PRESENT(p_cfield2d_2) ) THEN 
    502                p_cfield2d_2(:,:) = zcfield2d_2(:,:) 
    503                CALL crs_lbc_lnk( p_cfield2d_2(:,:),cd_type,1.0, pval=1.0 ) 
    504                 
    505                IF ( cd_op == 'SUM') THEN  
    506                   DO jii = 1 , jpiglo_crs 
    507                   p_cfield2d_2(jii,1) = p_cfield2d_2(jii,1) * 3 
    508                   ENDDO 
    509                ENDIF 
    510             ENDIF 
    511  
    512          ELSE 
    513  
    514             CALL crs_lbc_lnk( zcfield2d_1(:,:),cd_type,1.0 )  
    515             IF ( PRESENT(p_cfield2d_1) ) p_cfield2d_1(:,:) = zcfield2d_1(:,:) 
    516             CALL crs_lbc_lnk( zcfield2d_2(:,:),cd_type,1.0 )  
    517             IF ( PRESENT(p_cfield2d_2) ) p_cfield2d_2(:,:) = zcfield2d_2(:,:) 
    518  
    519          ENDIF 
    520  
    521          ! Take care now of 3d arrays 
    522          IF ( cd_op == 'SUM' .OR. cd_op == 'VOL' .OR. cd_op == 'POS'  ) THEN 
    523             CALL crs_lbc_lnk( zcfield3d_1(:,:,:),cd_type,1.0 )  
    524             IF ( PRESENT(p_cfield3d_1) ) p_cfield3d_1(:,:,:) = zcfield3d_1(:,:,:) 
    525             CALL crs_lbc_lnk( zcfield3d_2(:,:,:),cd_type,1.0 )  
    526             IF ( PRESENT(p_cfield3d_2) ) p_cfield3d_2(:,:,:) = zcfield3d_2(:,:,:) 
    527          ELSE 
    528             p_cfield3d_1(:,:,:) = zcfield3d_1(:,:,:) 
    529             CALL crs_lbc_lnk( p_cfield3d_1(:,:,:),cd_type,1.0 ) 
    530  
    531             ! Fill upper-right corner i=1, j=jpj_crs 
    532             IF ( nperio == 4 ) THEN 
    533                p_cfield3d_1(1,jpj_crs,:) = p_cfield3d_1(jpi_crsm1,jpj_crs-2,:) 
    534             ELSEIF ( nperio == 6 ) THEN 
    535                p_cfield3d_1(1,jpj_crs,:) = p_cfield3d_1(jpi_crs,jpj_crsm1,:) 
    536             ENDIF 
    537  
    538          ENDIF 
    539  
    540       CALL wrk_dealloc(jpi    , jpj         , ze1, ze2 ) 
    541       CALL wrk_dealloc(jpi    , jpj    , jpk, ze3 ) 
    542       CALL wrk_dealloc(jpi_crs, jpj_crs,      zcfield2d_1,  zcfield2d_2 ) 
    543       CALL wrk_dealloc(jpi_crs, jpj_crs, jpk, zcfield3d_1,  zcfield3d_2 ) 
    544  
    545    END SUBROUTINE crsfun_wgt 
    546  
    547  
    548    SUBROUTINE crsfun_UV( p_e1_e2, cd_type, psgn, p_pmask, p_fse3, p_pfield, p_surf_crs, p_cfield3d ) 
     343      CALL wrk_alloc( jpi, jpj, jpk, zvol ) 
     344 
     345      DO jk = 1, jpk 
     346         zvol(:,:,jk) =  p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk)  
     347      ENDDO 
     348 
     349      DO jk = 1, jpk            
     350         DO ji = nistr, niend, nn_factx 
     351            DO jj   = njstr, njend, nn_facty 
     352               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     353               ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     354               ijje = mje_crs(ij) 
     355               ijie = mie_crs(ii) 
     356               ! 
     357               p_fld1_crs(ii,ij,jk) =  zvol(ji,jj  ,jk) + zvol(ji+1,jj  ,jk) + zvol(ji+2,jj  ,jk)  & 
     358                   &                 + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk)  & 
     359                   &                 + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk)   
     360            ENDDO 
     361         ENDDO 
     362      ENDDO 
     363 
     364      IF( cd_type == 'T' ) THEN 
     365         DO jk = 1, jpk            
     366            DO ji = nistr, niend, nn_factx 
     367               DO jj   = njstr, njend, nn_facty 
     368                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     369                  ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     370                  ijje = mje_crs(ij) 
     371                  ijie = mie_crs(ii) 
     372                  ! 
     373                  zdAm =  zvol(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk)  & 
     374                    &   + zvol(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk)  & 
     375                    &   + zvol(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk)  & 
     376                    &   + zvol(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk)  & 
     377                    &   + zvol(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk)  & 
     378                    &   + zvol(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk)  & 
     379                    &   + zvol(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk)  & 
     380                    &   + zvol(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk)  & 
     381                    &   + zvol(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) 
     382                    !  
     383                   IF( p_fld1_crs(ii,ij,jk) /= 0._wp ) p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk)  
     384                   !  
     385               ENDDO 
     386            ENDDO 
     387         ENDDO 
     388      ENDIF 
     389      ! 
     390      IF( cd_type == 'W' ) THEN 
     391         DO jk = 2, jpk            
     392            DO ji = nistr, niend, nn_factx 
     393               DO jj   = njstr, njend, nn_facty 
     394                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     395                  ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     396                  ijje = mje_crs(ij) 
     397                  ijie = mie_crs(ii) 
     398                  ! 
     399                  zdAm =  zvol(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1)  & 
     400                    &   + zvol(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1)  & 
     401                    &   + zvol(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1)  & 
     402                    &   + zvol(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1)  & 
     403                    &   + zvol(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1)  & 
     404                    &   + zvol(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1)  & 
     405                    &   + zvol(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1)  & 
     406                    &   + zvol(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1)  & 
     407                    &   + zvol(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) 
     408                  ! 
     409                  IF( p_fld1_crs(ii,ij,jk) /= 0._wp ) p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk)  
     410                  ! 
     411               ENDDO 
     412            ENDDO 
     413         ENDDO 
     414         DO ji = nistr, niend, nn_factx 
     415            DO jj   = njstr, njend, nn_facty 
     416               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     417               ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     418               ijje = mje_crs(ij) 
     419               ijie = mie_crs(ii) 
     420               ! 
     421               zdAm =  zvol(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1)  & 
     422                 &   + zvol(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1)  & 
     423                 &   + zvol(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1)  & 
     424                 &   + zvol(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1)  & 
     425                 &   + zvol(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1)  & 
     426                 &   + zvol(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1)  & 
     427                 &   + zvol(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1)  & 
     428                 &   + zvol(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1)  & 
     429                 &   + zvol(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) 
     430               !  
     431               IF( p_fld1_crs(ii,ij,1) /= 0._wp ) p_fld2_crs(ii,ij,1) = zdAm / p_fld2_crs(ii,ij,1)  
     432               !  
     433            ENDDO 
     434         ENDDO 
     435      ENDIF 
     436       
     437      !                                             !  Retroactively add back the boundary halo cells. 
     438      CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 )  
     439      CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 )  
     440      ! 
     441      CALL wrk_dealloc( jpi, jpj, jpk, zvol ) 
     442      ! 
     443   END SUBROUTINE crs_dom_facvol 
     444 
     445 
     446   SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs ) 
    549447      !!---------------------------------------------------------------- 
    550448      !!               *** SUBROUTINE crsfun_UV *** 
    … …  
    571469      !!  
    572470      !!  Arguments 
    573       REAL(wp), DIMENSION(jpi,jpj),     INTENT(in)     :: p_e1_e2    ! Parent grid U,V scale factors (e1 or e2) 
    574       CHARACTER(len=1),                 INTENT(in)     :: cd_type    ! grid type U,V  
    575       REAL(wp),                         INTENT(in)     :: psgn       ! sign change option across north fold 
    576       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)     :: p_pmask    ! Parent grid U,V mask 
    577       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)     :: p_fse3     ! Parent grid vertical level thickness (fse3u, fse3v) 
    578       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)     :: p_pfield   ! U or V on parent grid 
     471      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_fld   ! T, U, V or W on parent grid 
     472      CHARACTER(len=3),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN 
     473      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V  
     474      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask 
     475      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2) 
     476      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v) 
    579477      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator     
    580  
    581       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)  :: p_cfield3d ! Coarse grid box 3D quantity  
     478      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V mask 
     479 
     480      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity  
    582481 
    583482      !! Local variables 
    584       INTEGER  :: ji, jj, jk , jii, jjj                  ! dummy loop indices 
    585       INTEGER  :: ijie, ijis, ijje, ijjs 
    586       REAL(wp), DIMENSION(:,:,:), POINTER :: zsurfcrs    
     483      INTEGER  :: ji, jj, jk                 ! dummy loop indices 
     484      INTEGER  :: ijie, ijje, ii, ij 
     485      REAL(wp) :: zflcrs, zsfcrs    
     486      REAL(wp) :: zeps = 1.e20     
     487      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf    
    587488 
    588489      !!----------------------------------------------------------------   
    589  
    590       CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zsurfcrs ) 
    591       zsurfcrs(:,:,:) = 1.0 
    592       IF ( PRESENT(p_surf_crs) ) THEN 
    593          WHERE ( p_surf_crs /= 0 ) zsurfcrs(:,:,:) = 1.0/p_surf_crs(:,:,:) 
    594       ENDIF 
    595  
    596       DO jk = 1, jpk     
    597  
    598         DO ji = 2, nlei_crs 
    599             ijie = mie_crs(ji) 
    600             ijis = mis_crs(ji) 
    601  
    602             DO jj = njstart, njend 
    603                ijje = mje_crs(jj)  
    604                ijjs = mjs_crs(jj)                    
    605  
    606                IF ( cd_type == 'V' ) THEN 
    607  
    608                   DO jii = ijis, ijie 
    609                      p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) & 
    610                        & + ( p_pfield(jii,ijje,jk) * p_e1_e2(jii,ijje) * p_fse3(jii,ijje,jk) * p_pmask(jii,ijje,jk) )  
     490    
     491 
     492      SELECT CASE ( cd_op ) 
     493       
     494         CASE ( 'VOL' ) 
     495       
     496            CALL wrk_alloc( jpi, jpj, jpk, zsurf ) 
     497            DO jk = 1, jpk 
     498              zsurf(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) 
     499            ENDDO 
     500          
     501            SELECT CASE ( cd_type ) 
     502             
     503               CASE( 'T' ) 
     504          
     505                  DO jk = 1, jpk 
     506                     
     507                     DO ji = nistr, niend, nn_factx 
     508                        DO jj = njstr, njend, nn_facty 
     509                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     510                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     511                           ijje = mje_crs(ij) 
     512                           ijie = mie_crs(ii)                   
     513  
     514                           zflcrs =  p_fld(ji  ,jj  ,jk) * zsurf(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk) & 
     515                             &     + p_fld(ji+1,jj  ,jk) * zsurf(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk) & 
     516                             &     + p_fld(ji+2,jj  ,jk) * zsurf(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk) & 
     517                             &     + p_fld(ji  ,jj+1,jk) * zsurf(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk) & 
     518                             &     + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk) & 
     519                             &     + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk) & 
     520                             &     + p_fld(ji  ,jj+2,jk) * zsurf(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk) & 
     521                             &     + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk) & 
     522                             &     + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk)  
     523  
     524                           zsfcrs =  zsurf(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk) & 
     525                             &     + zsurf(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk) & 
     526                             &     + zsurf(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk) & 
     527                             &     + zsurf(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk) & 
     528                             &     + zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk) & 
     529                             &     + zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk) & 
     530                             &     + zsurf(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk) & 
     531                             &     + zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk) & 
     532                             &     + zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk)  
     533                           ! 
     534                           p_fld_crs(ii,ij,jk) = zflcrs 
     535                           IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 
     536 
     537                        ENDDO       
     538                     ENDDO 
     539                  ENDDO    
     540             
     541               CASE( 'W' ) 
     542          
     543                  DO jk = 2, jpk 
     544                     
     545                     DO ji = nistr, niend, nn_factx 
     546                        DO jj = njstr, njend, nn_facty 
     547                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     548                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     549                           ijje = mje_crs(ij) 
     550                           ijie = mie_crs(ii)                   
     551  
     552                           zflcrs =  p_fld(ji  ,jj  ,jk) * zsurf(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1) & 
     553                             &     + p_fld(ji+1,jj  ,jk) * zsurf(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1) & 
     554                             &     + p_fld(ji+2,jj  ,jk) * zsurf(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1) & 
     555                             &     + p_fld(ji  ,jj+1,jk) * zsurf(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1) & 
     556                             &     + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1) & 
     557                             &     + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1) & 
     558                             &     + p_fld(ji  ,jj+2,jk) * zsurf(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1) & 
     559                             &     + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1) & 
     560                             &     + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1)  
     561  
     562                           zsfcrs =  zsurf(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1) & 
     563                             &     + zsurf(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1) & 
     564                             &     + zsurf(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1) & 
     565                             &     + zsurf(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1) & 
     566                             &     + zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1) & 
     567                             &     + zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1) & 
     568                             &     + zsurf(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1) & 
     569                             &     + zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1) & 
     570                             &     + zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1)  
     571                           ! 
     572                           p_fld_crs(ii,ij,jk) = zflcrs 
     573                           IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 
     574 
     575                        ENDDO       
     576                     ENDDO 
     577                  ENDDO    
     578 
     579                  DO ji = nistr, niend, nn_factx 
     580                     DO jj = njstr, njend, nn_facty 
     581                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     582                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     583                        ijje = mje_crs(ij) 
     584                        ijie = mie_crs(ii)                   
     585 
     586                          zflcrs =   p_fld(ji  ,jj  ,1) * zsurf(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1) & 
     587                             &     + p_fld(ji+1,jj  ,1) * zsurf(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1) & 
     588                             &     + p_fld(ji+2,jj  ,1) * zsurf(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1) & 
     589                             &     + p_fld(ji  ,jj+1,1) * zsurf(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1) & 
     590                             &     + p_fld(ji+1,jj+1,1) * zsurf(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1) & 
     591                             &     + p_fld(ji+2,jj+1,1) * zsurf(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1) & 
     592                             &     + p_fld(ji  ,jj+2,1) * zsurf(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1) & 
     593                             &     + p_fld(ji+1,jj+2,1) * zsurf(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1) & 
     594                             &     + p_fld(ji+2,jj+2,1) * zsurf(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1)  
     595  
     596                           zsfcrs =  zsurf(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1) & 
     597                             &     + zsurf(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1) & 
     598                             &     + zsurf(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1) & 
     599                             &     + zsurf(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1) & 
     600                             &     + zsurf(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1) & 
     601                             &     + zsurf(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1) & 
     602                             &     + zsurf(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1) & 
     603                             &     + zsurf(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1) & 
     604                             &     + zsurf(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1)  
     605                          
     606                        p_fld_crs(ii,ij,1) = zflcrs 
     607                        IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,1) = zflcrs / zsfcrs 
     608 
     609                     ENDDO       
    611610                  ENDDO 
    612                   p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) * zsurfcrs(ji,jj,jk)  
    613  
    614                ELSEIF ( cd_type == 'U') THEN 
    615  
    616                   DO jjj = ijjs, ijje 
    617                      p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) & 
    618                        & + ( p_pfield(ijie,jjj,jk) * p_e1_e2(ijie,jjj) * p_fse3(ijie,jjj,jk) * p_pmask(ijie,jjj,jk) ) 
     611 
     612              END SELECT 
     613 
     614              CALL wrk_dealloc( jpi, jpj, jpk, zsurf ) 
     615 
     616         CASE ( 'SUM' ) 
     617          
     618            CALL wrk_alloc( jpi, jpj, jpk, zsurf ) 
     619            DO jk = 1, jpk 
     620              zsurf(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) 
     621            ENDDO 
     622          
     623            SELECT CASE ( cd_type ) 
     624             
     625               CASE( 'T' ) 
     626          
     627                  DO jk = 1, jpk 
     628                     DO ji = nistr, niend, nn_factx 
     629                        DO jj = njstr, njend, nn_facty 
     630                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     631                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     632                           ijje = mje_crs(ij) 
     633                           ijie = mie_crs(ii)                   
     634  
     635                           zflcrs  =  p_fld(ji  ,jj  ,jk) * zsurf(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk) & 
     636                             &      + p_fld(ji+1,jj  ,jk) * zsurf(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk) & 
     637                             &      + p_fld(ji+2,jj  ,jk) * zsurf(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk) & 
     638                             &      + p_fld(ji  ,jj+1,jk) * zsurf(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk) & 
     639                             &      + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk) & 
     640                             &      + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk) & 
     641                             &      + p_fld(ji  ,jj+2,jk) * zsurf(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk) & 
     642                             &      + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk) & 
     643                             &      + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk)  
     644                           ! 
     645                           p_fld_crs(ii,ij,jk) = zflcrs 
     646                           ! 
     647                        ENDDO       
     648                     ENDDO 
     649                  ENDDO    
     650             
     651               CASE( 'W' ) 
     652          
     653                  DO jk = 2, jpk 
     654                     DO ji = nistr, niend, nn_factx 
     655                        DO jj = njstr, njend, nn_facty 
     656                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     657                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     658                           ijje = mje_crs(ij) 
     659                           ijie = mie_crs(ii) 
     660                           !                   
     661                           zflcrs  =  p_fld(ji  ,jj  ,jk) * zsurf(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1) & 
     662                             &      + p_fld(ji+1,jj  ,jk) * zsurf(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1) & 
     663                             &      + p_fld(ji+2,jj  ,jk) * zsurf(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1) & 
     664                             &      + p_fld(ji  ,jj+1,jk) * zsurf(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1) & 
     665                             &      + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1) & 
     666                             &      + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1) & 
     667                             &      + p_fld(ji  ,jj+2,jk) * zsurf(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1) & 
     668                             &      + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1) & 
     669                             &      + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1)  
     670                           ! 
     671                           p_fld_crs(ii,ij,jk) = zflcrs 
     672                           ! 
     673                        ENDDO       
     674                     ENDDO 
     675                  ENDDO    
     676 
     677                  DO ji = nistr, niend, nn_factx 
     678                     DO jj = njstr, njend, nn_facty 
     679                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     680                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     681                        ijje = mje_crs(ij) 
     682                        ijie = mie_crs(ii)                   
     683                        ! 
     684                        zflcrs  =   p_fld(ji  ,jj  ,1) * zsurf(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1) & 
     685                           &      + p_fld(ji+1,jj  ,1) * zsurf(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1) & 
     686                           &      + p_fld(ji+2,jj  ,1) * zsurf(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1) & 
     687                           &      + p_fld(ji  ,jj+1,1) * zsurf(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1) & 
     688                           &      + p_fld(ji+1,jj+1,1) * zsurf(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1) & 
     689                           &      + p_fld(ji+2,jj+1,1) * zsurf(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1) & 
     690                           &      + p_fld(ji  ,jj+2,1) * zsurf(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1) & 
     691                           &      + p_fld(ji+1,jj+2,1) * zsurf(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1) & 
     692                           &      + p_fld(ji+2,jj+2,1) * zsurf(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1)  
     693                        ! 
     694                        p_fld_crs(ii,ij,1) = zflcrs 
     695                        ! 
     696                     ENDDO       
    619697                  ENDDO 
    620                   p_cfield3d(ji,jj,jk) = p_cfield3d(ji,jj,jk) * zsurfcrs(ji,jj,jk) 
    621  
    622                ENDIF 
    623                   
    624             ENDDO 
    625          ENDDO 
    626       ENDDO 
    627  
    628 ! Retroactively add back the boundary halo cells. 
    629  
    630       CALL crs_lbc_lnk( p_cfield3d(:,:,:),cd_type,psgn ) 
    631        
    632       CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zsurfcrs ) 
    633  
    634    END SUBROUTINE crsfun_UV 
    635  
    636    SUBROUTINE crsfun_TW( p_e1e2t, cd_type, cd_op, p_cmask, p_ptmask, psgn, p_pfield2d, p_pfield3d_1, p_pfield3d_2, & 
    637       &                  p_cfield2d, p_cfield3d) 
     698            
     699               CASE( 'V' ) 
     700          
     701                  DO jk = 1, jpk 
     702                     DO ji = nistr, niend, nn_factx 
     703                        DO jj = njstr, njend, nn_facty 
     704                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     705                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     706                           ijje = mje_crs(ij) 
     707                           ijie = mie_crs(ii) 
     708                           !                   
     709                           zflcrs  =  p_fld(ji  ,ijje,jk) * zsurf(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) & 
     710                             &      + p_fld(ji+1,ijje,jk) * zsurf(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) & 
     711                             &      + p_fld(ji+2,ijje,jk) * zsurf(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk)  
     712                           ! 
     713                           p_fld_crs(ii,ij,jk) = zflcrs 
     714                           ! 
     715                         ENDDO       
     716                     ENDDO 
     717                  ENDDO    
     718 
     719             
     720               CASE( 'U' ) 
     721          
     722                  DO jk = 1, jpk 
     723                     DO ji = nistr, niend, nn_factx 
     724                        DO jj = njstr, njend, nn_facty 
     725                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     726                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     727                           ijje = mje_crs(ij) 
     728                           ijie = mie_crs(ii) 
     729                           !                   
     730                           zflcrs =  p_fld(ijie,jj  ,jk) * zsurf(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) & 
     731                             &     + p_fld(ijie,jj+1,jk) * zsurf(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) & 
     732                             &     + p_fld(ijie,jj+2,jk) * zsurf(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) 
     733                           ! 
     734                           p_fld_crs(ii,ij,jk) = zflcrs 
     735                           ! 
     736                        ENDDO       
     737                     ENDDO 
     738                  ENDDO    
     739 
     740              END SELECT 
     741 
     742              IF( PRESENT( p_surf_crs ) ) THEN 
     743                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:) 
     744              ENDIF 
     745 
     746              CALL wrk_dealloc( jpi, jpj, jpk, zsurf ) 
     747 
     748         CASE ( 'MAX' ) 
     749          
     750            SELECT CASE ( cd_type ) 
     751             
     752               CASE( 'T' ) 
     753          
     754                  DO jk = 1, jpk 
     755                     DO ji = nistr, niend, nn_factx 
     756                        DO jj = njstr, njend, nn_facty 
     757                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     758                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     759                           ijje = mje_crs(ij) 
     760                           ijie = mie_crs(ii)                   
     761  
     762                           zflcrs =  MAX( p_fld(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  & 
     763                             &            p_fld(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  & 
     764                             &            p_fld(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  & 
     765                             &            p_fld(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk),  & 
     766                             &            p_fld(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk),  & 
     767                             &            p_fld(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  & 
     768                             &            p_fld(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  & 
     769                             &            p_fld(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  & 
     770                             &            p_fld(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk)   ) 
     771                           ! 
     772                           p_fld_crs(ii,ij,jk) = zflcrs 
     773                           ! 
     774                        ENDDO       
     775                     ENDDO 
     776                  ENDDO    
     777             
     778               CASE( 'W' ) 
     779          
     780                  DO jk = 2, jpk 
     781                     DO ji = nistr, niend, nn_factx 
     782                        DO jj = njstr, njend, nn_facty 
     783                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     784                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     785                           ijje = mje_crs(ij) 
     786                           ijie = mie_crs(ii) 
     787                           !                   
     788                           zflcrs =  MAX( p_fld(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  & 
     789                             &            p_fld(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  & 
     790                             &            p_fld(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1),  & 
     791                             &            p_fld(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1),  & 
     792                             &            p_fld(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1),  & 
     793                             &            p_fld(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1),  & 
     794                             &            p_fld(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1),  & 
     795                             &            p_fld(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1),  & 
     796                             &            p_fld(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 
     797                           ! 
     798                           p_fld_crs(ii,ij,jk) = zflcrs 
     799                           ! 
     800                        ENDDO       
     801                     ENDDO 
     802                  ENDDO    
     803 
     804                  DO ji = nistr, niend, nn_factx 
     805                     DO jj = njstr, njend, nn_facty 
     806                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     807                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     808                        ijje = mje_crs(ij) 
     809                        ijie = mie_crs(ii)                   
     810                        ! 
     811                        zflcrs = MAX( p_fld(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  & 
     812                           &          p_fld(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  & 
     813                           &          p_fld(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1),  & 
     814                           &          p_fld(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1),  & 
     815                           &          p_fld(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1),  & 
     816                           &          p_fld(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1),  & 
     817                           &          p_fld(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1),  & 
     818                           &          p_fld(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1),  & 
     819                           &          p_fld(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1)  )  
     820                         ! 
     821                         p_fld_crs(ii,ij,1) = zflcrs 
     822                         ! 
     823                     ENDDO       
     824                  ENDDO 
     825            
     826               CASE( 'V' ) 
     827          
     828                  DO jk = 1, jpk 
     829                     DO ji = nistr, niend, nn_factx 
     830                        DO jj = njstr, njend, nn_facty 
     831                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     832                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     833                           ijje = mje_crs(ij) 
     834                           ijie = mie_crs(ii) 
     835                           !                   
     836                           zflcrs = MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk),  & 
     837                             &           p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk),  & 
     838                             &           p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) ) 
     839                           ! 
     840                           p_fld_crs(ii,ij,jk) = zflcrs 
     841                           ! 
     842                        ENDDO       
     843                     ENDDO 
     844                  ENDDO    
     845 
     846             
     847               CASE( 'U' ) 
     848          
     849                  DO jk = 1, jpk 
     850                     DO ji = nistr, niend, nn_factx 
     851                        DO jj = njstr, njend, nn_facty 
     852                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     853                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     854                           ijje = mje_crs(ij) 
     855                           ijie = mie_crs(ii) 
     856                           !                   
     857                           Zflcrs = MAX( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk),  & 
     858                             &           p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk),  & 
     859                             &           p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) ) 
     860                           ! 
     861                           p_fld_crs(ii,ij,jk) = zflcrs 
     862                           ! 
     863                        ENDDO       
     864                     ENDDO 
     865                  ENDDO    
     866 
     867              END SELECT 
     868 
     869         CASE ( 'MIN' ) 
     870            !   Search the min of masked grid cells 
     871            SELECT CASE ( cd_type ) 
     872             
     873               CASE( 'T' ) 
     874          
     875                  DO jk = 1, jpk 
     876                     DO ji = nistr, niend, nn_factx 
     877                        DO jj = njstr, njend, nn_facty 
     878                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     879                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     880                           ijje = mje_crs(ij) 
     881                           ijie = mie_crs(ii)                   
     882                            
     883                           zflcrs =  MIN( p_fld(ji  ,jj  ,jk) * ( 1. + ( 1. - p_mask(ji  ,jj  ,jk) ) * zeps ),  & 
     884                             &            p_fld(ji+1,jj  ,jk) * ( 1. + ( 1. - p_mask(ji+1,jj  ,jk) ) * zeps ),  & 
     885                             &            p_fld(ji+2,jj  ,jk) * ( 1. + ( 1. - p_mask(ji+2,jj  ,jk) ) * zeps ),  & 
     886                             &            p_fld(ji  ,jj+1,jk) * ( 1. + ( 1. - p_mask(ji  ,jj  ,jk) ) * zeps ),  & 
     887                             &            p_fld(ji+1,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk) ) * zeps ),  & 
     888                             &            p_fld(ji+2,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk) ) * zeps ),  & 
     889                             &            p_fld(ji  ,jj+2,jk) * ( 1. + ( 1. - p_mask(ji  ,jj  ,jk) ) * zeps ),  & 
     890                             &            p_fld(ji+1,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk) ) * zeps ),  & 
     891                             &            p_fld(ji+2,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk) ) * zeps )   ) 
     892                           ! 
     893                           p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 
     894                           ! 
     895                        ENDDO       
     896                     ENDDO 
     897                  ENDDO    
     898            
     899               CASE( 'W' ) 
     900          
     901                  DO jk = 2, jpk 
     902                     DO ji = nistr, niend, nn_factx 
     903                        DO jj = njstr, njend, nn_facty 
     904                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     905                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     906                           ijje = mje_crs(ij) 
     907                           ijie = mie_crs(ii)                   
     908                            
     909                           zflcrs =  MIN( p_fld(ji  ,jj  ,jk) * ( 1. + ( 1. - p_mask(ji  ,jj  ,jk-1) ) * zeps ),  & 
     910                             &            p_fld(ji+1,jj  ,jk) * ( 1. + ( 1. - p_mask(ji+1,jj  ,jk-1) ) * zeps ),  & 
     911                             &            p_fld(ji+2,jj  ,jk) * ( 1. + ( 1. - p_mask(ji+2,jj  ,jk-1) ) * zeps ),  & 
     912                             &            p_fld(ji  ,jj+1,jk) * ( 1. + ( 1. - p_mask(ji  ,jj  ,jk-1) ) * zeps ),  & 
     913                             &            p_fld(ji+1,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk-1) ) * zeps ),  & 
     914                             &            p_fld(ji+2,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk-1) ) * zeps ),  & 
     915                             &            p_fld(ji  ,jj+2,jk) * ( 1. + ( 1. - p_mask(ji  ,jj  ,jk-1) ) * zeps ),  & 
     916                             &            p_fld(ji+1,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk-1) ) * zeps ),  & 
     917                             &            p_fld(ji+2,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk-1) ) * zeps )   ) 
     918                           ! 
     919                           p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 
     920                           ! 
     921                        ENDDO       
     922                     ENDDO 
     923                  ENDDO   
     924  
     925                  DO ji = nistr, niend, nn_factx 
     926                     DO jj = njstr, njend, nn_facty 
     927                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     928                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     929                        ijje = mje_crs(ij) 
     930                        ijie = mie_crs(ii)                   
     931                         
     932                        zflcrs =  MIN( p_fld(ji  ,jj  ,1) * ( 1. + ( 1. - p_mask(ji  ,jj  ,1) ) * zeps ),  & 
     933                          &            p_fld(ji+1,jj  ,1) * ( 1. + ( 1. - p_mask(ji+1,jj  ,1) ) * zeps ),  & 
     934                          &            p_fld(ji+2,jj  ,1) * ( 1. + ( 1. - p_mask(ji+2,jj  ,1) ) * zeps ),  & 
     935                          &            p_fld(ji  ,jj+1,1) * ( 1. + ( 1. - p_mask(ji  ,jj  ,1) ) * zeps ),  & 
     936                          &            p_fld(ji+1,jj+1,1) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ),  & 
     937                          &            p_fld(ji+2,jj+1,1) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps ),  & 
     938                          &            p_fld(ji  ,jj+2,1) * ( 1. + ( 1. - p_mask(ji  ,jj  ,1) ) * zeps ),  & 
     939                          &            p_fld(ji+1,jj+2,1) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ),  & 
     940                          &            p_fld(ji+2,jj+2,1) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps )   ) 
     941                        ! 
     942                        p_fld_crs(ii,ij,1) = zflcrs * p_mask_crs(ii,ij,1) 
     943                        ! 
     944                     ENDDO       
     945                  ENDDO 
     946 
     947               CASE( 'V' ) 
     948          
     949                  DO jk = 1, jpk 
     950                     DO ji = nistr, niend, nn_factx 
     951                        DO jj = njstr, njend, nn_facty 
     952                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     953                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     954                           ijje = mje_crs(ij) 
     955                           ijie = mie_crs(ii)                   
     956                            
     957                           zflcrs =  MIN( p_fld(ji  ,ijje,jk) * ( 1. + ( 1. - p_mask(ji  ,ijje,jk) ) * zeps ),  & 
     958                             &            p_fld(ji+1,ijje,jk) * ( 1. + ( 1. - p_mask(ji+1,ijje,jk) ) * zeps ),  & 
     959                             &            p_fld(ji+2,ijje,jk) * ( 1. + ( 1. - p_mask(ji+2,ijje,jk) ) * zeps )   ) 
     960                           ! 
     961                           p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 
     962                           ! 
     963                        ENDDO       
     964                     ENDDO 
     965                  ENDDO   
     966 
     967 
     968               CASE( 'U' ) 
     969          
     970                  DO jk = 1, jpk 
     971                     DO ji = nistr, niend, nn_factx 
     972                        DO jj = njstr, njend, nn_facty 
     973                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     974                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     975                           ijje = mje_crs(ij) 
     976                           ijie = mie_crs(ii)                   
     977                            
     978                           zflcrs =  MIN( p_fld(ijie,jj  ,jk) * ( 1. + ( 1. - p_mask(ijie,jj  ,jk) ) * zeps ),  & 
     979                             &            p_fld(ijie,jj+1,jk) * ( 1. + ( 1. - p_mask(ijie,jj+1,jk) ) * zeps ),  & 
     980                             &            p_fld(ijie,jj+2,jk) * ( 1. + ( 1. - p_mask(ijie,jj+2,jk) ) * zeps )   ) 
     981                           ! 
     982                           p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 
     983                           ! 
     984                        ENDDO       
     985                     ENDDO 
     986                  ENDDO   
     987            END SELECT 
     988            ! 
     989         END SELECT 
     990         ! 
     991         CALL crs_lbc_lnk( p_fld_crs, cd_type, 1.0 ) 
     992         ! 
     993    END SUBROUTINE crs_dom_ope_3d 
     994 
     995    SUBROUTINE crs_dom_ope_2d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs ) 
    638996      !!---------------------------------------------------------------- 
    639       !!               *** SUBROUTINE crsfun_TW *** 
    640       !! ** Purpose :  Five applications. 
    641       !!               1) Maximum surface quantity  
    642       !!                  - Vertical scale factors (fse3t or fse3w)  
    643       !!                    max thickness of the parent grid for coarse grid scale factors. 
    644       !!                  - or diffusion test 
    645       !!               2) Area-weighted mean quantity: w, or other 3D or 2D quantity 
    646       !!               3) Volume-weighted mean quantity: tracer 
    647       !!               4) Minimum surface quantity (diffusion test) 
    648       !!               5) Area- or Volume- weighted sum. 
    649       !! ** Method  :  1) - cd_op = 'MAX'. Determines the max vertical thickness of grid boxes 
    650       !!                    including partial steps for at the bottom 
    651       !!                    for the coarsened grid, where within the subset of  
    652       !!                    the parent grid cells the maximum thickness is taken. 
    653       !!                    Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 
    654       !!                    Where, normally p_pfield3d_1 is e3t. 
    655       !!                  - cd_op = 'MAX'. May also be used for say, determining the maximum value of Kz,  
    656       !!                    thus p_pfield3d_1 is set to the 3D field, Kz. 
    657       !!                    Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 
    658       !!               2) - cd_op = 'ARE'. Calculate the area-weighted average (surface e1t*e2t)   
    659       !!                    of vertical velocity, w. 
    660       !!                    Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 
    661       !!                  - cd_op = 'ARE'. Calculate area-weighted average of a 2D quantity (e.g. emp) 
    662       !!                    Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield2d 
    663       !!               3) - cd_op = 'VOL'. Calculate the ocean volume (e1e2t*[fse3t|fse3w])  
    664       !!                    Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 
    665       !!                  - cd_op = 'VOL'. Calculate volume-weighted average (volume e1t*e2t*fse3t) of a quantity. 
    666       !!                    Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1, p_pfield3d_2 
    667       !!               4) - cd_op = 'MIN'. Calculate the minimum value on surface e1t*e2t for 3D variables 
    668       !!                  Valid arguments: p_e1e2t, cd_type, cd_op, p_cmask, p_pfield3d_1 
    669       !!               5) - cd_op = 'SUM'. Calculate a dimesionally-weighted sum.  This could be area-weighted 
    670       !!                  or volume-weighted sum.  
    671       !! ** Inputs  : p_e1e2t      = parent grid top face surface area, e1t*e2t  
    672       !!              cd_type      = grid type T, W (U, V, F)  
    673       !!              cd_op        = MAX, ARE, VOL, MIN, SUM 
    674       !!              p_cmask      =  coarse grid mask 
    675       !!              p_ptmask     =  parent grid tmask      
    676       !!              psgn         = (Optional) sign for lbc_lnk   
    677       !!              p_pfield2d   = (Optional) 2D field on parent grid 
    678       !!              p_pfield3d_1 = (Optional) parent grid fse3t or fse3w 
    679       !!              p_pfield3d_2 = (Optional) 3D field on parent grid 
    680       !! ** Outputs : p_cfield2d   = (Optional) 2D field on coarse grid 
    681       !!              p_cfield3d   = (Optional) 3D field on coarse grid 
     997      !!               *** SUBROUTINE crsfun_UV *** 
     998      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces  
    682999      !! 
    683       !!  
    684       !! History.  30 May.  Editing.  To decide later: Keep all functionality or separate out the mean function. 
    685       !!            7 Jun   TODO. Need to fix up the parent grid mask to optional like crsfun_UV... 
     1000      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages 
     1001      !!               on the east and north faces, respectively, 
     1002      !!               of the parent grid subset comprising the coarse grid box.  
     1003      !!               In the case of the V and F grid, the last jrow minus 1 is spurious. 
     1004      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f) 
     1005      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V) 
     1006      !!              psgn        = sign change over north fold (See lbclnk.F90) 
     1007      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors;  
     1008      !!                                       for velocities (U or V) 
     1009      !!              p_fse3      = parent grid vertical level thickness (fse3u or fse3v) 
     1010      !!              p_pfield    = U or V on the parent grid 
     1011      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging 
     1012      !! ** Outputs : p_cfield3d = 3D field on coarse grid 
     1013      !! 
     1014      !! History.  29 May.  completed draft. 
     1015      !!            4 Jun.  Revision for WGT 
     1016      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights. 
    6861017      !!---------------------------------------------------------------- 
    6871018      !!  
    6881019      !!  Arguments 
    689       REAL(wp), DIMENSION(jpi,jpj),               INTENT(in) :: p_e1e2t      ! Parent grid T surface (e1*e2) 
    690       CHARACTER(len=1),                           INTENT(in) :: cd_type      ! grid type T, W ( U, V, F) 
    691       CHARACTER(len=3),                           INTENT(in) :: cd_op        ! operation max, min, area-average, volume-average 
    692       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk),   INTENT(in) :: p_cmask      ! Coarse grid T mask 
    693       REAL(wp), DIMENSION(jpi,jpj,jpk),           INTENT(in) :: p_ptmask     ! Parent grid T mask 
    694       REAL(wp),                         OPTIONAL, INTENT(in) :: psgn         ! sign for lbc_lnk 
    695       REAL(wp), DIMENSION(jpi,jpj),     OPTIONAL, INTENT(in) :: p_pfield2d   ! 2D quantity on parent grid, e.g. ssh 
    696       REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(in) :: p_pfield3d_1 ! Normally parent grid vertical level thickness 
    697       REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL, INTENT(in) :: p_pfield3d_2 ! 3D tracer or W on parent grid 
    698  
    699       REAL(wp), DIMENSION(jpi_crs,jpj_crs),     OPTIONAL, INTENT(out):: p_cfield2d ! Coarse grid box east or north face quantity 
    700       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), OPTIONAL, INTENT(out):: p_cfield3d ! Coarse grid box east or north face quantity  
     1020      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in)           :: p_fld   ! T, U, V or W on parent grid 
     1021      CHARACTER(len=3),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN 
     1022      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V  
     1023      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask 
     1024      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2) 
     1025      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v) 
     1026      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator     
     1027      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V mask 
     1028 
     1029      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity  
    7011030 
    7021031      !! Local variables 
    703       INTEGER ::  ji, jj, jk                   ! dummy loop indices 
    704       INTEGER :: ijie,ijis,ijje,ijjs,ijpk,jii,jjj 
    705       INTEGER, DIMENSION(3) :: idims 
    706       REAL(wp), POINTER, DIMENSION(:,:)   :: ze1e2, zpfield2d, zcfield2d 
    707       REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3, zpfield3d, zcfield3d, zcmask, zpmask   
    708       REAL(wp)                            :: zdAm, zsgn 
     1032      INTEGER  :: ji, jj, jk                 ! dummy loop indices 
     1033      INTEGER  :: ijie, ijje, ii, ij 
     1034      REAL(wp) :: zflcrs, zsfcrs    
     1035      REAL(wp) :: zeps = 1.e20     
     1036      REAL(wp), DIMENSION(:,:), POINTER :: zsurf    
     1037 
    7091038      !!----------------------------------------------------------------   
    710       ! Initialize 
    711  
    712       CALL wrk_alloc(jpi    , jpj         , ze1e2, zpfield2d ) 
    713       CALL wrk_alloc(jpi    , jpj    , jpk,  ze3 , zpfield3d, zpmask ) 
    714       CALL wrk_alloc(jpi_crs, jpj_crs,      zcfield2d ) 
    715       CALL wrk_alloc(jpi_crs, jpj_crs, jpk, zcfield3d,  zcmask ) 
    716  
    717  
    718       ! Arrays, scalars initialization  
    719       zpfield2d(:,:)   = 0.0 
    720       zpfield3d(:,:,:) = 0.0 
    721       zcfield2d(:,:)   = 0.0 
    722       zcfield3d(:,:,:) = 0.0 
    723       zpmask(:,:,:)    = 1.0 
    724       idims(:)         = 1 
    725  
    726       zcmask(:,:,:)    = p_cmask(:,:,:)      
    727       zpmask(:,:,:)    = p_ptmask(:,:,:) 
    728  
    729       ijpk             = jpk 
    730  
    731  
    732       ! Control of optional arguments 
    733       ! 
    734       IF ( PRESENT(psgn) ) THEN 
    735          zsgn = psgn 
    736       ELSE 
    737          zsgn = 1.0  
    738       ENDIF 
    739       ! 
    740       IF ( TRIM(cd_op) == 'MAX' ) THEN 
    741          ! Find the maximum thickness in each parent grid subset 
    742          IF ( PRESENT(p_pfield3d_1) )  THEN 
    743             zpfield3d(:,:,:) = p_pfield3d_1(:,:,:) 
    744             ze3(:,:,:) = 0.0 
    745             ze1e2(:,:) = 0.0 
    746          ELSE  
    747             WRITE(numout,*) 'crsfun_TW. MAX only 3D arrays supported'  
    748          ENDIF  
    749       ELSEIF ( TRIM(cd_op) == 'VOL' ) THEN 
    750          IF ( PRESENT(p_pfield3d_1) ) THEN 
    751             ze3(:,:,:)       = p_pfield3d_1(:,:,:) 
    752             IF ( PRESENT(p_pfield3d_2) ) THEN 
    753 !              ! Prep to calculate a volume-averaged mean 
    754                zpfield3d(:,:,:) = p_pfield3d_2(:,:,:) 
    755                ze1e2(:,:)       = p_e1e2t(:,:)      
    756             ELSE 
    757                WRITE(numout,*) 'crsfun_TW. WARNING. Supply both e3t and the field for volume-averaged field' 
    758             ENDIF 
    759          ELSE 
    760             WRITE(numout,*) 'crsfun_TW. VOL only 3D arrays supported'   
    761          ENDIF 
    762       ELSEIF ( TRIM(cd_op) == 'ARE' ) THEN 
    763          ze1e2(:,:) = p_e1e2t(:,:) 
    764          ze3(:,:,:) = 1.0 
    765          IF ( PRESENT(p_pfield3d_2) ) THEN 
    766             ! Prep to do the area-weighted average of (3D) W 
    767             zpfield3d(:,:,:) = p_pfield3d_2(:,:,:) 
    768          ELSEIF ( PRESENT(p_pfield2d) ) THEN 
    769             ! Prep to do the area-weighted average of some 2D quantity  
    770             zpfield2d(:,:) = p_pfield2d(:,:)  
    771             ijpk=1 
    772          ENDIF 
    773       ELSEIF ( TRIM(cd_op) == 'MIN' ) THEN 
    774          IF ( PRESENT(p_pfield3d_1) ) THEN 
    775             ! Prep to do get the minimum diffusion on the top face 
    776             zpfield3d(:,:,:) = p_pfield3d_1(:,:,:) 
    777             ze3(:,:,:) = 0.0 
    778             ze1e2(:,:) = 0.0 
    779          ELSE 
    780             WRITE(numout,*) 'crsfun_TW. MIN Only 3D arrays supported'  
    781          ENDIF 
    782       ELSEIF ( TRIM(cd_op) == 'SUM' ) THEN 
    783          ze1e2(:,:) = p_e1e2t(:,:) 
    784          zpmask(:,:,:) = p_ptmask(:,:,:) 
    785          ze3(:,:,:) = 1.0 
    786         IF ( PRESENT(p_pfield3d_1) ) THEN 
    787             IF ( PRESENT(p_pfield3d_2) ) THEN 
    788 !              ! Prep to calculate a volume-weighted sum 
    789                zpfield3d(:,:,:) = p_pfield3d_2(:,:,:) 
    790                ze3(:,:,:) = p_pfield3d_1(:,:,:) 
    791             ELSE 
    792                ! Prep to do the area-weighted sum of (3D) W 
    793                zpfield3d(:,:,:) = p_pfield3d_1(:,:,:) 
    794             ENDIF 
    795          ELSEIF ( PRESENT(p_pfield2d) ) THEN 
    796             ! Prep to do the area-weighted sum of some 2D quantity  
    797             zpfield2d(:,:) = p_pfield2d(:,:)  
    798             ijpk=1 
    799          ENDIF  
    800       ELSE 
    801          WRITE(numout,*) 'crsfun_TW. valid cd_op are MAX, MIN, ARE, VOL, SUM'  
    802       ENDIF 
    803  
    804       ! Determine output  
    805       DO jk = 1, ijpk     
    806  
    807          IF ( ijpk == jpk ) zpfield2d(:,:) = zpfield3d(:,:,jk)  
    808          zcfield2d(:,:) = 0.0  
    809  
    810            DO ji = 2, nlei_crs 
    811                ijie = mie_crs(ji) 
    812                ijis = mis_crs(ji) 
    813  
    814              DO jj = njstart, njend 
    815                   ijje = mje_crs(jj)  
    816                   ijjs = mjs_crs(jj)                    
    817  
    818                   ! First determine weighted sums  
    819                   IF ( TRIM(cd_op) == 'SUM' .OR. TRIM(cd_op) == 'ARE' .OR. TRIM(cd_op) == 'VOL' ) THEN 
    820                      ! Area- or volume- weighted sum 
    821                      ! Accumulate to sum in parent grid subset  
    822                     DO jii = ijis, ijie 
    823                         DO jjj = ijjs, ijje 
    824                            zcfield2d(ji,jj) = zcfield2d(ji,jj) & 
    825                               &              + ( zpfield2d(jii,jjj)      & 
    826                               &                  *   ze1e2(jii,jjj)      & 
    827                               &                  *     ze3(jii,jjj,jk)   & 
    828                               &                  *  zpmask(jii,jjj,jk) )  
    829  
    830                         ENDDO 
     1039    
     1040 
     1041      SELECT CASE ( cd_op ) 
     1042       
     1043         CASE ( 'VOL' ) 
     1044       
     1045           CALL wrk_alloc( jpi, jpj, zsurf ) 
     1046           zsurf(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 
     1047                     
     1048           DO ji = nistr, niend, nn_factx 
     1049              DO jj = njstr, njend, nn_facty 
     1050                 ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1051                 ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1052                 ijje = mje_crs(ij) 
     1053                 ijie = mie_crs(ii)                   
     1054  
     1055                 zflcrs =  p_fld(ji  ,jj  ) * zsurf(ji  ,jj  )  & 
     1056                   &     + p_fld(ji+1,jj  ) * zsurf(ji+1,jj  )  & 
     1057                   &     + p_fld(ji+2,jj  ) * zsurf(ji+2,jj  )  & 
     1058                   &     + p_fld(ji  ,jj+1) * zsurf(ji  ,jj+1)  & 
     1059                   &     + p_fld(ji+1,jj+1) * zsurf(ji+1,jj+1)  & 
     1060                   &     + p_fld(ji+2,jj+1) * zsurf(ji+2,jj+1)  & 
     1061                   &     + p_fld(ji  ,jj+2) * zsurf(ji  ,jj+2)  & 
     1062                   &     + p_fld(ji+1,jj+2) * zsurf(ji+1,jj+2)  & 
     1063                   &     + p_fld(ji+2,jj+2) * zsurf(ji+2,jj+2)   
     1064 
     1065                 zsfcrs =  zsurf(ji,jj  ) + zsurf(ji+1,jj  ) + zsurf(ji+2,jj  )  & 
     1066                   &     + zsurf(ji,jj+1) + zsurf(ji+1,jj+1) + zsurf(ji+2,jj+1)  & 
     1067                   &     + zsurf(ji,jj+2) + zsurf(ji+1,jj+2) + zsurf(ji+2,jj+2)   
     1068                 ! 
     1069                 p_fld_crs(ii,ij) = zflcrs 
     1070                 IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij) = zflcrs / zsfcrs 
     1071 
     1072              ENDDO       
     1073           ENDDO 
     1074             
     1075           CALL wrk_dealloc( jpi, jpj, zsurf ) 
     1076 
     1077         CASE ( 'SUM' ) 
     1078          
     1079            CALL wrk_alloc( jpi, jpj, zsurf ) 
     1080            zsurf(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 
     1081          
     1082            SELECT CASE ( cd_type ) 
     1083             
     1084               CASE( 'T', 'W' ) 
     1085          
     1086                  DO ji = nistr, niend, nn_factx 
     1087                     DO jj = njstr, njend, nn_facty 
     1088                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1089                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1090                        ijje = mje_crs(ij) 
     1091                        ijie = mie_crs(ii)                   
     1092 
     1093                        zflcrs  =  p_fld(ji  ,jj  ) * zsurf(ji  ,jj  )  & 
     1094                          &      + p_fld(ji+1,jj  ) * zsurf(ji+1,jj  )  & 
     1095                          &      + p_fld(ji+2,jj  ) * zsurf(ji+2,jj  )  & 
     1096                          &      + p_fld(ji  ,jj+1) * zsurf(ji  ,jj+1)  & 
     1097                          &      + p_fld(ji+1,jj+1) * zsurf(ji+1,jj+1)  & 
     1098                          &      + p_fld(ji+2,jj+1) * zsurf(ji+2,jj+1)  & 
     1099                          &      + p_fld(ji  ,jj+2) * zsurf(ji  ,jj+2)  & 
     1100                          &      + p_fld(ji+1,jj+2) * zsurf(ji+1,jj+2)  & 
     1101                          &      + p_fld(ji+2,jj+2) * zsurf(ji+2,jj+2)   
     1102                        ! 
     1103                        p_fld_crs(ii,ij) = zflcrs 
     1104                        ! 
     1105                     ENDDO       
     1106                  ENDDO 
     1107             
     1108               CASE( 'V' ) 
     1109          
     1110                  DO jk = 1, jpk 
     1111                     DO ji = nistr, niend, nn_factx 
     1112                        DO jj = njstr, njend, nn_facty 
     1113                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1114                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1115                           ijje = mje_crs(ij) 
     1116                           ijie = mie_crs(ii) 
     1117                           !                   
     1118                           zflcrs  =  p_fld(ji  ,ijje) * zsurf(ji  ,ijje)  & 
     1119                             &      + p_fld(ji+1,ijje) * zsurf(ji+1,ijje)  & 
     1120                             &      + p_fld(ji+2,ijje) * zsurf(ji+2,ijje)   
     1121                           ! 
     1122                           p_fld_crs(ii,ij) = zflcrs 
     1123                           ! 
     1124                         ENDDO       
    8311125                     ENDDO 
    832  
    833                   ENDIF 
    834  
    835                   ! Calculate weighted average if desired 
    836                   IF ( TRIM(cd_op) == 'ARE' .OR. TRIM(cd_op) == 'VOL' ) THEN 
    837  
    838                      ! Area- or volume- weighted mean 
    839                      ! Sum first parent grid subset   
    840                      zdAm = 0.0 
    841                      DO jii = ijis, ijie 
    842                         DO jjj = ijjs, ijje 
    843                            zdAm = zdAm + (   ze1e2(jii,jjj)               & 
    844                               &           *    ze3(jii,jjj,jk)            & 
    845                               &           * zpmask(jii,jjj,jk) ) 
    846                         ENDDO 
     1126                  ENDDO    
     1127 
     1128             
     1129               CASE( 'U' ) 
     1130          
     1131                  DO jk = 1, jpk 
     1132                     DO ji = nistr, niend, nn_factx 
     1133                        DO jj = njstr, njend, nn_facty 
     1134                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1135                           ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1136                           ijje = mje_crs(ij) 
     1137                           ijie = mie_crs(ii) 
     1138                           !                   
     1139                           zflcrs =  p_fld(ijie,jj  ) * zsurf(ijie,jj  )  & 
     1140                             &     + p_fld(ijie,jj+1) * zsurf(ijie,jj+1)  & 
     1141                             &     + p_fld(ijie,jj+2) * zsurf(ijie,jj+2)  
     1142                           ! 
     1143                           p_fld_crs(ii,ij) = zflcrs 
     1144                           ! 
     1145                        ENDDO       
    8471146                     ENDDO 
    848                       
    849                      IF ( zdAm /= 0 )  zcfield2d(ji,jj) = zcfield2d(ji,jj) / zdAm 
    850  
    851                   ENDIF 
    852  
    853  
    854                   IF ( TRIM(cd_op) == 'MAX' ) THEN 
    855                      ! Find max in parent grid subset  
    856                      DO jii = ijis, ijie 
    857                         DO jjj = ijjs, ijje 
    858                            zcfield2d(ji,jj) = MAX( zcfield2d(ji,jj), zpfield3d(jii,jjj,jk)*zpmask(jii,jjj,jk) )  
    859                         ENDDO 
    860                      ENDDO 
    861                   ENDIF 
    862  
    863                   IF ( TRIM(cd_op) == 'MIN' ) THEN 
    864                      ! Find min in parent grid subset   
    865                      DO jii = ijis, ijie 
    866                         DO jjj = ijjs, ijje 
    867                            IF ( zpmask(jii,jjj,jk) == 1 ) THEN 
    868                               zcfield2d(ji,jj) = MIN( zcfield2d(ji,jj), zpfield3d(jii,jjj,jk) )  
    869                            ENDIF 
    870                         ENDDO 
    871                      ENDDO 
    872                   ENDIF 
    873  
    874                ENDDO 
    875             ENDDO 
    876  
    877             IF ( ijpk == 1 ) THEN 
    878                IF ( PRESENT(p_cfield2d) ) p_cfield2d(:,:) = zcfield2d(:,:) * zcmask(:,:,jk) 
    879             ELSE 
    880                IF ( PRESENT(p_cfield3d) ) p_cfield3d(:,:,jk) = zcfield2d(:,:) * zcmask(:,:,jk) 
    881             ENDIF     
    882  
    883       ENDDO 
    884  
    885  
    886 ! Retroactively add back the boundary halo cells. 
    887  
    888          IF ( ijpk == 1 ) THEN 
    889             IF ( PRESENT(p_cfield2d) ) CALL crs_lbc_lnk( p_cfield2d(:,:),cd_type,zsgn ) 
    890          ELSE 
    891             IF ( PRESENT(p_cfield3d) ) THEN 
    892                CALL crs_lbc_lnk( p_cfield3d(:,:,:),cd_type,zsgn ) 
    893             ENDIF 
    894          ENDIF 
    895       
    896       CALL wrk_dealloc(jpi    , jpj         , ze1e2, zpfield2d ) 
    897       CALL wrk_dealloc(jpi    , jpj    , jpk,  ze3 , zpfield3d, zpmask ) 
    898       CALL wrk_dealloc(jpi_crs, jpj_crs,      zcfield2d ) 
    899       CALL wrk_dealloc(jpi_crs, jpj_crs, jpk, zcfield3d,  zcmask ) 
     1147                  ENDDO    
     1148 
     1149              END SELECT 
     1150 
     1151              IF( PRESENT( p_surf_crs ) ) THEN 
     1152                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:) 
     1153              ENDIF 
     1154 
     1155              CALL wrk_dealloc( jpi, jpj, zsurf ) 
     1156 
     1157         CASE ( 'MAX' ) 
     1158          
     1159            SELECT CASE ( cd_type ) 
     1160             
     1161               CASE( 'T', 'W' ) 
     1162          
     1163                  DO ji = nistr, niend, nn_factx 
     1164                     DO jj = njstr, njend, nn_facty 
     1165                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1166                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1167                        ijje = mje_crs(ij) 
     1168                        ijie = mie_crs(ii)                   
     1169 
     1170                        zflcrs =  MAX( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1),  & 
     1171                          &            p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1),  & 
     1172                          &            p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1),  & 
     1173                          &            p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1),  & 
     1174                          &            p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1),  & 
     1175                          &            p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1),  & 
     1176                          &            p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1),  & 
     1177                          &            p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1),  & 
     1178                          &            p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1)   ) 
     1179                        ! 
     1180                        p_fld_crs(ii,ij) = zflcrs 
     1181                        ! 
     1182                     ENDDO       
     1183                  ENDDO 
     1184             
     1185               CASE( 'V' ) 
     1186          
     1187                  DO ji = nistr, niend, nn_factx 
     1188                     DO jj = njstr, njend, nn_facty 
     1189                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1190                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1191                        ijje = mje_crs(ij) 
     1192                        ijie = mie_crs(ii) 
     1193                        !                   
     1194                        zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1),  & 
     1195                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1),  & 
     1196                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) ) 
     1197                        ! 
     1198                        p_fld_crs(ii,ij) = zflcrs 
     1199                        ! 
     1200                     ENDDO       
     1201                  ENDDO 
     1202             
     1203               CASE( 'U' ) 
     1204          
     1205                  DO ji = nistr, niend, nn_factx 
     1206                     DO jj = njstr, njend, nn_facty 
     1207                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1208                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1209                        ijje = mje_crs(ij) 
     1210                        ijie = mie_crs(ii) 
     1211                        !                   
     1212                        zflcrs = MAX( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1),  & 
     1213                          &           p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1),  & 
     1214                          &           p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) ) 
     1215                        ! 
     1216                        p_fld_crs(ii,ij) = zflcrs 
     1217                        ! 
     1218                     ENDDO       
     1219                  ENDDO 
     1220 
     1221              END SELECT 
     1222 
     1223         CASE ( 'MIN' ) 
     1224            !   Search the min of masked grid cells 
     1225            SELECT CASE ( cd_type ) 
     1226             
     1227               CASE( 'T', 'W' ) 
     1228          
     1229                  DO ji = nistr, niend, nn_factx 
     1230                     DO jj = njstr, njend, nn_facty 
     1231                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1232                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1233                        ijje = mje_crs(ij) 
     1234                        ijie = mie_crs(ii)                   
     1235                         
     1236                        zflcrs =  MIN( p_fld(ji  ,jj  ) * ( 1. + ( 1. - p_mask(ji  ,jj  ,1) ) * zeps ),  & 
     1237                          &            p_fld(ji+1,jj  ) * ( 1. + ( 1. - p_mask(ji+1,jj  ,1) ) * zeps ),  & 
     1238                          &            p_fld(ji+2,jj  ) * ( 1. + ( 1. - p_mask(ji+2,jj  ,1) ) * zeps ),  & 
     1239                          &            p_fld(ji  ,jj+1) * ( 1. + ( 1. - p_mask(ji  ,jj  ,1) ) * zeps ),  & 
     1240                          &            p_fld(ji+1,jj+1) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ),  & 
     1241                          &            p_fld(ji+2,jj+1) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps ),  & 
     1242                          &            p_fld(ji  ,jj+2) * ( 1. + ( 1. - p_mask(ji  ,jj  ,1) ) * zeps ),  & 
     1243                          &            p_fld(ji+1,jj+2) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ),  & 
     1244                          &            p_fld(ji+2,jj+2) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps )   ) 
     1245                        ! 
     1246                        p_fld_crs(ii,ij) = zflcrs * p_mask_crs(ii,ij,1) 
     1247                        ! 
     1248                     ENDDO       
     1249                  ENDDO 
    9001250  
    901  
    902    END SUBROUTINE crsfun_TW 
     1251               CASE( 'V' ) 
     1252          
     1253                  DO ji = nistr, niend, nn_factx 
     1254                     DO jj = njstr, njend, nn_facty 
     1255                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1256                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1257                        ijje = mje_crs(ij) 
     1258                        ijie = mie_crs(ii)                   
     1259                         
     1260                        zflcrs =  MIN( p_fld(ji  ,ijje) * ( 1. + ( 1. - p_mask(ji  ,ijje,1) ) * zeps ),  & 
     1261                          &            p_fld(ji+1,ijje) * ( 1. + ( 1. - p_mask(ji+1,ijje,1) ) * zeps ),  & 
     1262                          &            p_fld(ji+2,ijje) * ( 1. + ( 1. - p_mask(ji+2,ijje,1) ) * zeps )   ) 
     1263                        ! 
     1264                        p_fld_crs(ii,ij) = zflcrs * p_mask_crs(ii,ij,1) 
     1265                        ! 
     1266                     ENDDO       
     1267                  ENDDO 
     1268 
     1269               CASE( 'U' ) 
     1270          
     1271                  DO ji = nistr, niend, nn_factx 
     1272                     DO jj = njstr, njend, nn_facty 
     1273                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1274                        ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1275                        ijje = mje_crs(ij) 
     1276                        ijie = mie_crs(ii)                   
     1277                         
     1278                        zflcrs =  MIN( p_fld(ijie,jj  ) * ( 1. + ( 1. - p_mask(ijie,jj  ,1) ) * zeps ),  & 
     1279                          &            p_fld(ijie,jj+1) * ( 1. + ( 1. - p_mask(ijie,jj+1,1) ) * zeps ),  & 
     1280                          &            p_fld(ijie,jj+2) * ( 1. + ( 1. - p_mask(ijie,jj+2,1) ) * zeps )   ) 
     1281                        ! 
     1282                        p_fld_crs(ii,ij) = zflcrs * p_mask_crs(ii,ij,1) 
     1283                        ! 
     1284                     ENDDO       
     1285                  ENDDO 
     1286            END SELECT 
     1287            ! 
     1288         END SELECT 
     1289         ! 
     1290         CALL crs_lbc_lnk( p_fld_crs, cd_type, 1.0 ) 
     1291         ! 
     1292   END SUBROUTINE crs_dom_ope_2d 
    9031293 
    9041294 
    … …  
    9141304      !! Local variables 
    9151305      INTEGER ::  ji, jj, jk                   ! dummy loop indices 
    916       INTEGER :: ijie,ijis,ijje,ijjs,jii,jjj 
     1306      INTEGER ::  ijie, ijje, ii, ij 
     1307      REAL(wp) :: ze3crs   
    9171308      !!----------------------------------------------------------------   
    9181309      ! Initialize 
    … …  
    9231314          
    9241315            DO jk = 1 , jpk 
    925                
    926                DO ji = 2, nlei_crs        ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 
    927                    ijie = mie_crs(ji) 
    928                    ijis = mis_crs(ji) 
    929  
    930                    DO jj =  njstart, njend  ! jj = jpj_crs definit par pivot T  
    931                       ijje = mje_crs(jj)  
    932                       ijjs = mjs_crs(jj)   
    933                        
    934                       DO jii = ijis, ijie 
    935                          DO jjj = ijjs, ijje 
    936                             p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk)  ) 
    937                          ENDDO 
    938                       ENDDO 
    939                    ENDDO 
     1316               DO ji = nistr, niend, nn_factx 
     1317                  DO jj = njstr, njend, nn_facty 
     1318                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     1319                     ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1320                     ijje = mje_crs(ij) 
     1321                     ijie = mie_crs(ii) 
     1322                     !   
     1323                     ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  & 
     1324                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  & 
     1325                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  & 
     1326                        &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk),  & 
     1327                        &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk),  & 
     1328                        &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  & 
     1329                        &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  & 
     1330                        &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  & 
     1331                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 
     1332                     
     1333                     p_e3_crs(ii,ij,jk) = ze3crs 
     1334                  ENDDO 
    9401335               ENDDO 
    9411336            ENDDO 
    … …  
    9441339          
    9451340            DO jk = 2 , jpk 
    946              
    947                                           ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 
    948                DO ji = 2, nlei_crs 
    949                    ijie = mie_crs(ji) 
    950                    ijis = mis_crs(ji) 
    951  
    952                    DO jj = njstart, njend ! jj = jpj_crs definit par pivot T  
    953                       ijje = mje_crs(jj)  
    954                       ijjs = mjs_crs(jj)   
    955                     
    956                       DO jii = ijis, ijie 
    957                          DO jjj = ijjs, ijje 
    958                             p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk-1)  ) 
    959                          ENDDO 
    960                       ENDDO 
    961                    ENDDO 
    962                ENDDO 
    963             ENDDO 
    964               
    965             jk = 1                                           ! cas particulier car zpmask(jii,jjj,0) n'existe pas       
    966            
    967             DO ji = 2, nlei_crs 
    968                ijie = mie_crs(ji) 
    969                ijis = mis_crs(ji) 
    970  
    971                DO jj = njstart, njend             
    972                   ijje = mje_crs(jj)  
    973                   ijjs = mjs_crs(jj)   
    974                     
    975                   DO jii = ijis, ijie 
    976                      DO jjj = ijjs, ijje 
    977                         p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk)  ) 
    978                      ENDDO 
     1341               DO ji = nistr, niend, nn_factx 
     1342                  DO jj = njstr, njend, nn_facty 
     1343                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     1344                     ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1345                     ijje = mje_crs(ij) 
     1346                     ijie = mie_crs(ii) 
     1347                     !   
     1348                     ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  & 
     1349                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  & 
     1350                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1),  & 
     1351                        &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1),  & 
     1352                        &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1),  & 
     1353                        &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1),  & 
     1354                        &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1),  & 
     1355                        &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1),  & 
     1356                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 
     1357                     
     1358                     p_e3_crs(ii,ij,jk) = ze3crs 
    9791359                  ENDDO 
    9801360               ENDDO 
    981             ENDDO   
     1361            ENDDO 
     1362              
     1363            DO ji = nistr, niend, nn_factx 
     1364               DO jj = njstr, njend, nn_facty 
     1365                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     1366                  ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1367                  ijje = mje_crs(ij) 
     1368                  ijie = mie_crs(ii) 
     1369                  !   
     1370                  ze3crs = MAX( p_e3(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  & 
     1371                     &          p_e3(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  & 
     1372                     &          p_e3(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1),  & 
     1373                     &          p_e3(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1),  & 
     1374                     &          p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1),  & 
     1375                     &          p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1),  & 
     1376                     &          p_e3(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1),  & 
     1377                     &          p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1),  & 
     1378                     &          p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 
     1379                  
     1380                  p_e3_crs(ii,ij,1) = ze3crs 
     1381               ENDDO 
     1382            ENDDO 
    9821383             
    9831384         END SELECT  
    984                    
    985          CALL crs_lbc_lnk( p_e3_crs(:,:,:),cd_type, 1.0, pval=1.0 )   
    986       
    987          WRITE(numout,*) 'crs_e3_max : end of subroutine ' 
    988   
    989  
     1385         !               
     1386         CALL crs_lbc_lnk( p_e3_crs, cd_type, 1.0, pval=1.0 )   
     1387         !               
    9901388   END SUBROUTINE crs_dom_e3_max 
    9911389 
    992  
    993    SUBROUTINE crs_dom_sfc( p_e1, p_e2, p_e3, cd_type, p_mask, p_surf_crs, p_surf_crs_msk ) 
     1390   SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk,  p_e1, p_e2, p_e3 ) 
    9941391 
    9951392      !!  Arguments 
    9961393      CHARACTER(len=1),                 INTENT(in) :: cd_type      ! grid type T, W ( U, V, F) 
    9971394      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask       ! Parent grid T mask 
    998       REAL(wp), DIMENSION(jpi,jpj)    , INTENT(in) :: p_e1, p_e2         ! 3D tracer T or W on parent grid 
    999       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3         ! 3D tracer T or W on parent grid 
    1000       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout):: p_surf_crs ! Coarse grid box east or north face quantity  
    1001       REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout):: p_surf_crs_msk ! Coarse grid box east or north face quantity  
     1395      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(in), OPTIONAL :: p_e1, p_e2         ! 3D tracer T or W on parent grid 
     1396      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3         ! 3D tracer T or W on parent grid 
     1397      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out):: p_surf_crs ! Coarse grid box east or north face quantity  
     1398      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out):: p_surf_crs_msk ! Coarse grid box east or north face quantity  
    10021399 
    10031400      !! Local variables 
    1004       INTEGER  ::  ji, jj, jk                   ! dummy loop indices 
    1005       INTEGER  :: ijie,ijis,ijje,ijjs,ijpk,jii,jjj 
    1006       REAL(wp) :: zsfc 
     1401      INTEGER  :: ji, jj, jk                   ! dummy loop indices 
     1402      INTEGER  :: ijie, ijje, ii, ij 
     1403      REAL(wp), DIMENSION(:,:)  , POINTER :: zsurf    
     1404      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf3d    
     1405      REAL(wp) :: zsfcrs, zsfcrs_msk 
    10071406      !!----------------------------------------------------------------   
    10081407      ! Initialize 
    10091408 
    1010       p_surf_crs    (:,:,:) = 0._wp 
    1011       p_surf_crs_msk(:,:,:) = 0._wp 
     1409 
    10121410      ! 
    10131411      SELECT CASE ( cd_type ) 
    10141412       
    10151413         CASE ('W') 
    1016  
    1017             DO jk = 2 , jpk 
    1018                 DO ji = 2, nlei_crs 
    1019                    ijie = mie_crs(ji) 
    1020                    ijis = mis_crs(ji) 
    1021                    DO jj = njstart, njend 
    1022                       ijje = mje_crs(jj)  
    1023                       ijjs = mjs_crs(jj) 
    1024                       DO jii = ijis, ijie 
    1025                          DO jjj = ijjs, ijje 
    1026                             zsfc = p_e1(jii,jjj) * p_e2(jii,jjj) 
    1027                             p_surf_crs(ji,jj,jk)     = p_surf_crs(ji,jj,jk) + zsfc 
    1028                             p_surf_crs_msk(ji,jj,jk) = p_surf_crs_msk(ji,jj,jk) + zsfc * p_mask(jii,jjj,jk-1)                
    1029                          ENDDO 
    1030                       ENDDO 
    1031                       IF( njstart == 1 ) p_surf_crs(ji,jj,jk) = p_surf_crs(ji,jj,jk) * nn_facty 
    1032                    ENDDO                   
     1414       
     1415           CALL wrk_alloc( jpi, jpj, zsurf ) 
     1416           zsurf(:,:) =  p_e1(:,:) * p_e2(:,:) 
     1417         
     1418            DO ji = nistr, niend, nn_factx 
     1419               DO jj   = njstr, njend, nn_facty 
     1420                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     1421                  ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1422                  ijje = mje_crs(ij) 
     1423                  ijie = mie_crs(ii) 
     1424                  ! 
     1425                  zsfcrs     =  zsurf(ji,jj  ) + zsurf(ji+1,jj  ) + zsurf(ji+2,jj  )  & 
     1426                    &         + zsurf(ji,jj+1) + zsurf(ji+1,jj+1) + zsurf(ji+2,jj+1)  & 
     1427                    &         + zsurf(ji,jj+2) + zsurf(ji+1,jj+2) + zsurf(ji+2,jj+2)   
     1428                  ! 
     1429                  zsfcrs_msk =  zsurf(ji  ,jj  ) * p_mask(ji  ,jj  ,1)  & 
     1430                    &         + zsurf(ji+1,jj  ) * p_mask(ji+1,jj  ,1)  & 
     1431                    &         + zsurf(ji+2,jj  ) * p_mask(ji+2,jj  ,1)  & 
     1432                    &         + zsurf(ji  ,jj+1) * p_mask(ji  ,jj+1,1)  & 
     1433                    &         + zsurf(ji+1,jj+1) * p_mask(ji+1,jj+1,1)  & 
     1434                    &         + zsurf(ji+2,jj+1) * p_mask(ji+2,jj+1,1)  & 
     1435                    &         + zsurf(ji  ,jj+2) * p_mask(ji  ,jj+2,1)  & 
     1436                    &         + zsurf(ji+1,jj+2) * p_mask(ji+1,jj+2,1)  & 
     1437                    &         + zsurf(ji+2,jj+2) * p_mask(ji+2,jj+2,1) 
     1438                  ! 
     1439                  p_surf_crs    (ii,ij,1) = zsfcrs 
     1440                  p_surf_crs_msk(ii,ij,1) = zsfcrs_msk 
     1441                  ! 
    10331442               ENDDO 
    10341443            ENDDO 
     1444            DO jk = 2, jpk 
     1445               ! 
     1446               p_surf_crs(:,:,jk) = p_surf_crs(:,:,1) 
     1447               ! 
     1448               DO ji = nistr, niend, nn_factx 
     1449                  DO jj   = njstr, njend, nn_facty 
     1450                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid 
     1451                     ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1452                     ijje = mje_crs(ij) 
     1453                     ijie = mie_crs(ii) 
     1454                     ! 
     1455                     zsfcrs_msk =  zsurf(ji  ,jj  ) * p_mask(ji  ,jj  ,jk-1)  & 
     1456                       &         + zsurf(ji+1,jj  ) * p_mask(ji+1,jj  ,jk-1)  & 
     1457                       &         + zsurf(ji+2,jj  ) * p_mask(ji+2,jj  ,jk-1)  & 
     1458                       &         + zsurf(ji  ,jj+1) * p_mask(ji  ,jj+1,jk-1)  & 
     1459                       &         + zsurf(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1)  & 
     1460                       &         + zsurf(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1)  & 
     1461                       &         + zsurf(ji  ,jj+2) * p_mask(ji  ,jj+2,jk-1)  & 
     1462                       &         + zsurf(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1)  & 
     1463                       &         + zsurf(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1) 
     1464                       ! 
     1465                       p_surf_crs_msk(ii,ij,jk) = zsfcrs_msk 
     1466                       ! 
     1467                   ENDDO 
     1468                ENDDO 
     1469            ENDDO 
    10351470                         
    1036             ! surface   ; ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 
    1037             DO ji = 2, nlei_crs 
    1038                ijie = mie_crs(ji) 
    1039                ijis = mis_crs(ji) 
    1040                DO jj = njstart, njend                            
    1041                   ijje = mje_crs(jj)  
    1042                   ijjs = mjs_crs(jj) 
    1043                   DO jii = ijis, ijie  
    1044                      DO jjj = ijjs, ijje 
    1045                         zsfc = p_e1(jii,jjj) * p_e2(jii,jjj) 
    1046                         p_surf_crs(ji,jj,1)     = p_surf_crs(ji,jj,1) + zsfc 
    1047                         p_surf_crs_msk(ji,jj,1) = p_surf_crs_msk(ji,jj,1) * zsfc * p_mask(jii,jjj,1)                
    1048                      ENDDO   
    1049                   ENDDO 
    1050                   IF( njstart == 1 ) p_surf_crs(ji,jj,1) = p_surf_crs(ji,jj,1) * nn_facty                
    1051                ENDDO 
    1052             ENDDO 
     1471            CALL wrk_dealloc( jpi, jpj, zsurf ) 
     1472           
     1473         CASE( 'V' ) 
     1474            
     1475           CALL wrk_alloc( jpi, jpj, jpk, zsurf3d ) 
     1476           DO jk = 1, jpk 
     1477              zsurf3d(:,:,jk) =  p_e1(:,:) * p_e3(:,:,jk) 
     1478           ENDDO 
     1479          
     1480           DO jk = 1, jpk 
     1481              DO ji = nistr, niend, nn_factx 
     1482                 DO jj = njstr, njend, nn_facty 
     1483                    ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1484                    ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1485                    ijje = mje_crs(ij) 
     1486                    ijie = mie_crs(ii) 
     1487                    !                   
     1488                    zsfcrs      =  zsurf3d(ji,ijje,jk) + zsurf3d(ji+1,ijje,jk) + zsurf3d(ji+2,ijje,jk) 
     1489                    ! 
     1490                    zsfcrs_msk  =  zsurf3d(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) & 
     1491                      &          + zsurf3d(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) & 
     1492                      &          + zsurf3d(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk)  
     1493                    ! 
     1494                    p_surf_crs    (ii,ij,jk) = zsfcrs 
     1495                    p_surf_crs_msk(ii,ij,jk) = zsfcrs_msk 
     1496                    ! 
     1497                  ENDDO       
     1498              ENDDO 
     1499           ENDDO    
     1500 
     1501           CALL wrk_dealloc( jpi, jpj, jpk, zsurf3d ) 
    10531502             
    1054        CASE ('U') 
    1055         
    1056           DO jk = 1 , jpk 
    1057                                              ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 
    1058              DO ji = 2, nlei_crs 
    1059                 ijie = mie_crs(ji) 
    1060                 ijis = mis_crs(ji) 
    1061                 DO jj = njstart, njend  
    1062                    ijje = mje_crs(jj)   
    1063                    ijjs = mjs_crs(jj) 
    1064                    DO jii = ijis, ijie 
    1065                       DO jjj = ijjs, ijje    
    1066                          zsfc =  p_e3(jii,jjj,jk) * p_e2(jii,jjj)   
    1067                          p_surf_crs(ji,jj,jk)     = p_surf_crs(ji,jj,jk) + zsfc 
    1068                          p_surf_crs_msk(ji,jj,jk) = p_surf_crs_msk(ji,jj,jk) + zsfc * p_mask(jii,jjj,jk)                
    1069                       ENDDO 
    1070                    ENDDO 
    1071                   IF( njstart == 1 ) p_surf_crs(ji,jj,jk) = p_surf_crs(ji,jj,jk) * nn_facty 
    1072                ENDDO 
    1073             ENDDO 
    1074          ENDDO 
    1075         
    1076       CASE ('V') 
    1077            
    1078          DO jk = 1 , ijpk 
    1079                                                                    ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 
    1080             DO ji = 2, nlei_crs 
    1081                ijie = mie_crs(ji) 
    1082                ijis = mis_crs(ji) 
    1083                DO jj = njstart, njend                  ! jj = jpj_crs definit par pivot T  
    1084                   ijje = mje_crs(jj)    
    1085                   ijjs = mjs_crs(jj)   
    1086                   DO jii = ijis, ijie 
    1087                      DO jjj = ijjs, ijje 
    1088                         zsfc = p_e3(jii,jjj,jk) * p_e1(jii,jjj)  
    1089                         p_surf_crs(ji,jj,jk)     = p_surf_crs(ji,jj,jk) + zsfc 
    1090                         p_surf_crs_msk(ji,jj,jk) = p_surf_crs_msk(ji,jj,jk) + zsfc * p_mask(jii,jjj,jk)    
    1091                      ENDDO 
    1092                   ENDDO 
    1093                ENDDO 
    1094             ENDDO 
    1095          ENDDO 
     1503         CASE( 'U' ) 
     1504          
     1505           CALL wrk_alloc( jpi, jpj, jpk, zsurf3d ) 
     1506           DO jk = 1, jpk 
     1507              zsurf3d(:,:,jk) =  p_e2(:,:) * p_e3(:,:,jk) 
     1508           ENDDO 
     1509          
     1510           DO jk = 1, jpk 
     1511              DO ji = nistr, niend, nn_factx 
     1512                 DO jj = njstr, njend, nn_facty 
     1513                    ii   = ( ji - mis_crs(2) ) * rfactx_r + 2      
     1514                    ij   = ( jj - mjs_crs(2) ) * rfacty_r + 2 
     1515                    ijje = mje_crs(ij) 
     1516                    ijie = mie_crs(ii) 
     1517                    !                   
     1518                    zsfcrs      =  zsurf3d(ijie,jj,jk) + zsurf3d(ijie,jj+1,jk) + zsurf3d(ijie,jj+2,jk) 
     1519                    ! 
     1520                    zsfcrs_msk  =  zsurf3d(ijie  ,jj,jk) * p_mask(ijie,jj  ,jk) & 
     1521                      &          + zsurf3d(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) & 
     1522                      &          + zsurf3d(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk)  
     1523                    ! 
     1524                    p_surf_crs    (ii,ij,jk) = zsfcrs 
     1525                    p_surf_crs_msk(ii,ij,jk) = zsfcrs_msk 
     1526                    ! 
     1527                  ENDDO       
     1528              ENDDO 
     1529           ENDDO   
     1530  
     1531           CALL wrk_dealloc( jpi, jpj, jpk, zsurf3d ) 
     1532 
    10961533      END SELECT 
    1097   
    1098        
    1099       CALL crs_lbc_lnk( p_surf_crs    (:,:,:), cd_type, 1.0, pval=1.0 ) 
    1100       CALL crs_lbc_lnk( p_surf_crs_msk(:,:,:), cd_type, 1.0, pval=1.0 ) 
     1534       
     1535      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pval=1.0 ) 
     1536      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 
    11011537 
    11021538 
    … …  
    11551591         nlej_crs   = jpj_crs 
    11561592          
    1157         !!! Calculs suivant une découpage en j 
    1158       
     1593        ! Calculs suivant une découpage en j 
    11591594        DO jn = 1, jpnij, jpni 
    1160           
    11611595           IF( jn < (jpnij-jpni + 1)) THEN 
    11621596              nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn     ) - 1) ) / nn_facty, wp ) ) & 
    … …  
    11671601            
    11681602           SELECT CASE( ibonjt(jn) ) 
    1169             
    11701603              CASE ( -1 ) 
    11711604                IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )    nlejt_crs(jn) = nlejt_crs(jn) + 1 
    … …  
    11981631           ENDDO 
    11991632        ENDDO  
    1200                  WRITE(numout,*) ' njmppt_crs', njmppt_crs 
    1201          nlej_crs  = nlejt_crs(nproc + 1)  
    1202          nlcj_crs  = nlcjt_crs(nproc + 1) 
    1203          nldj_crs  = nldjt_crs(nproc + 1) 
    1204          njmpp_crs = njmppt_crs(nproc + 1) 
    1205  
    1206  
     1633        nlej_crs  = nlejt_crs(nproc + 1)  
     1634        nlcj_crs  = nlcjt_crs(nproc + 1) 
     1635        nldj_crs  = nldjt_crs(nproc + 1) 
     1636        njmpp_crs = njmppt_crs(nproc + 1) 
    12071637 
    12081638         !!!! Calcul suivant un decoupage en i 
    … …  
    12181648            
    12191649                 CASE ( -1 ) 
    1220                   
    12211650                   nleit_crs(jn) = nleit_crs(jn) + jpreci            
    12221651                   nlcit_crs(jn) = nleit_crs(jn) + jpreci 
    … …  
    12241653               
    12251654                 CASE ( 0 ) 
    1226                
    12271655                   nleit_crs(jn) = nleit_crs(jn) + jpreci 
    12281656                   nlcit_crs(jn) = nleit_crs(jn) + jpreci 
    … …  
    12301658                 
    12311659                 CASE ( 1, 2 ) 
    1232                   
    12331660                   IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )    nleit_crs(jn) = nleit_crs(jn) + 1 
    12341661                   nleit_crs(jn) = nleit_crs(jn) + jpreci 
    … …  
    12541681         nimpp_crs = nimppt_crs(nproc + 1) 
    12551682 
    1256  
    1257           
    1258          !!! rajouter la condition stop 
     1683         ! rajouter la condition stop 
    12591684         IF( jpizoom /= 1 .OR. jpjzoom /= 1)    STOP  
    12601685         DO ji = 1, jpi_crs 
    … …  
    12651690         ENDDO 
    12661691 
    1267           
    1268            
    12691692      ENDIF 
    12701693       
    … …  
    14341857      END SELECT 
    14351858 
    1436  
    1437         ! Pad the boundaries, do not know if it is necessary 
    1438          mis2_crs(1) = 1            ; mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1    
    1439          mie2_crs(1) = nn_factx     ; mie2_crs(jpiglo_crs) = jpiglo                          
    1440          mje2_crs(1) = mjs2_crs(2)-1; mje2_crs(jpjglo_crs) = jpjglo 
    1441          mjs2_crs(1) = 1            ; mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1  
    1442   
    1443  
    1444           
     1859     ! Pad the boundaries, do not know if it is necessary 
     1860      mis2_crs(1) = 1             ; mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1    
     1861      mie2_crs(1) = nn_factx      ; mie2_crs(jpiglo_crs) = jpiglo                          
     1862      mje2_crs(1) = mjs2_crs(2)-1 ; mje2_crs(jpjglo_crs) = jpjglo 
     1863      mjs2_crs(1) = 1             ; mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1  
    14451864  
    14461865      IF( .NOT. lk_mpp ) THEN      
    1447          njstart = 1     ;    njend =  jpj_crsm1 
    1448          mis_crs(:) = mis2_crs(:)  
    1449          mie_crs(:) = mie2_crs(:) 
    1450          mjs_crs(:) = mjs2_crs(:)  
    1451          mje_crs(:) = mje2_crs(:) 
     1866        mis_crs(:) = mis2_crs(:)  
     1867        mie_crs(:) = mie2_crs(:) 
     1868        mjs_crs(:) = mjs2_crs(:)  
     1869        mje_crs(:) = mje2_crs(:)  
    14521870      ELSE 
    1453          ! 
    1454          IF( nldj==1 )  THEN  ;   njstart = 1 
    1455          ELSE                 ;   njstart = 2 
    1456          ENDIF 
    1457          ! 
    1458          IF(nlcj == nlej) THEN 
    1459             njend = nlej_crs - 1 
    1460          ELSE 
    1461             njend = nlej_crs 
    1462          ENDIF 
    1463           
    1464          DO jj = 1, nlej_crs 
    1465             mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 
    1466             mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 
    1467          ENDDO 
    1468          DO ji = 1, nlei_crs 
    1469             mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 
    1470             mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 
    1471          ENDDO 
    1472  
    1473          ! 
     1871        DO jj = 1, nlej_crs 
     1872           mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 
     1873           mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 
     1874        ENDDO 
     1875        DO ji = 1, nlei_crs 
     1876           mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 
     1877           mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 
     1878        ENDDO 
    14741879      ENDIF 
    1475          WRITE(numout,*) 'crs_init. coarse grid bounds on parent grid' 
    1476          WRITE(numout,*) 'mjg_crs='  , mjg_crs 
    1477          WRITE(numout,*) 'mig_crs='  , mig_crs 
    1478          WRITE(numout,*) 'nimpp_crs=', nimpp_crs 
    1479          WRITE(numout,*) 'njmpp_crs=', njmpp_crs 
    1480          WRITE(numout,*) 'njend='    , njend 
    1481          WRITE(numout,*) 'mis_crs='  , mis_crs 
    1482          WRITE(numout,*) 'mie_crs='  , mie_crs 
    1483          WRITE(numout,*) 'mjs_crs='  , mjs_crs 
    1484          WRITE(numout,*) 'mje_crs='  , mje_crs 
    1485     
    1486     
     1880      njstr = mjs_crs(2)  ;   njend = mjs_crs(nlcj_crs - 1) 
     1881      nistr = mis_crs(2)  ;   niend = mis_crs(nlci_crs - 1) 
     1882      WRITE(numout,*) 'crs_init. coarse grid bounds on parent grid' 
     1883      WRITE(numout,*) 'mjg_crs='  , mjg_crs 
     1884      WRITE(numout,*) 'mig_crs='  , mig_crs 
     1885      WRITE(numout,*) 'nimpp_crs=', nimpp_crs 
     1886      WRITE(numout,*) 'njmpp_crs=', njmpp_crs 
     1887      WRITE(numout,*) 'njend='    , njend 
     1888      WRITE(numout,*) 'mis_crs='  , mis_crs 
     1889      WRITE(numout,*) 'mie_crs='  , mie_crs 
     1890      WRITE(numout,*) 'mjs_crs='  , mjs_crs 
     1891      WRITE(numout,*) 'mje_crs='  , mje_crs 
     1892      ! 
    14871893   END SUBROUTINE crs_dom_def 
    14881894    
    14891895   SUBROUTINE crs_dom_bat 
    1490     !!---------------------------------------------------------------- 
     1896      !!---------------------------------------------------------------- 
    14911897      !!               *** SUBROUTINE crs_dom_bat *** 
    14921898      !! ** Purpose :  coarsenig bathy 
    … …  
    14941900      !!  
    14951901      !!  local variables 
    1496  
     1902      INTEGER  :: ji,jj,jk      ! dummy indices 
     1903      REAL(wp), DIMENSION(:,:)  , POINTER :: zmbk 
     1904      !!---------------------------------------------------------------- 
    14971905    
    1498    INTEGER  :: ji,jj,jk      ! dummy indices 
    1499    REAL(wp), DIMENSION(:,:)  , POINTER :: zmbk 
    1500     
    1501    CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 
     1906      CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 
    15021907    
    15031908      mbathy_crs(:,:) = jpkm1 
    … …  
    15381943      END DO 
    15391944 
    1540       WRITE(numout,*) 'crsini. Set mbku, mkbv' 
    1541  
    15421945      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    1543    
    15441946      zmbk(:,:) = 1.e0;     
    15451947      zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs  (:,:) = MAX( INT( zmbk(:,:) ), 1 )  
    … …  
    15471949      ! 
    15481950      CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk ) 
    1549       WRITE(numout,*) 'crs_init   = finished section 3d.1 jpi=', jpi, 'jpj=',jpj, ' jpk=', jpk 
    1550  
     1951      ! 
    15511952   END SUBROUTINE crs_dom_bat 
    15521953 

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90

    r3864 r3895  
    2121   USE lib_mpp         ! MPP library 
    2222!   USE wrk_nemo        ! Memory allocation 
     23   USE iom_def 
    2324   USE iom 
    2425   USE crs         ! coarse grid domain 
    … …  
    295296      SELECT CASE ( MOD(nn_msh_crs, 3) ) 
    296297      CASE ( 1 )                 
    297          CALL iom_close( inum0 ) 
     298         CALL crs_iom_close( inum0 ) 
    298299      CASE ( 2 ) 
    299          CALL iom_close( inum1 ) 
    300          CALL iom_close( inum2 ) 
     300         CALL crs_iom_close( inum1 ) 
     301         CALL crs_iom_close( inum2 ) 
    301302      CASE ( 0 ) 
    302          CALL iom_close( inum2 ) 
    303          CALL iom_close( inum3 ) 
    304          CALL iom_close( inum4 ) 
     303         CALL crs_iom_close( inum2 ) 
     304         CALL crs_iom_close( inum3 ) 
     305         CALL crs_iom_close( inum4 ) 
    305306      END SELECT 
    306307      ! 

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90

    r3864 r3895  
    1515   USE in_out_manager 
    1616   USE par_kind, ONLY: wp 
    17    USE crs 
    1817   USE crsdom 
    1918   USE crsdomwri 
    … …  
    208207 
    209208     !    3.d.3   Vertical depth (meters) 
    210  
    211      CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, & 
    212           &       p_pfield3d_1=gdept, p_cfield3d=gdept_crs )  
    213      CALL crsfun( p_e1e2t=e1e2t, cd_type='W', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, & 
    214           &       p_pfield3d_1=gdepw, p_cfield3d=gdepw_crs ) 
     209     CALL crs_dom_ope( gdept, 'MAX', 'T', tmask, gdept_crs, p_e3=zfse3t )  
     210     CALL crs_dom_ope( gdepw, 'MAX', 'W', tmask, gdepw_crs, p_e3=zfse3w ) 
     211 
    215212 
    216213     !    3.d.4   Surfaces  
    217        
    218      CALL crs_dom_sfc( e1t, e2t, zfse3w, 'W', tmask, e1e2w, e1e2w_msk ) 
    219      CALL crs_dom_sfc( e1u, e2u, zfse3u, 'U', umask, e2e3u, e2e3u_msk ) 
    220      CALL crs_dom_sfc( e1v, e2v, zfse3v, 'V', vmask, e1e3v, e1e3v_msk ) 
     214     CALL crs_dom_sfc( tmask, 'T', e1e2w, e1e2w_msk, p_e1=e1t, p_e2=e2t ) 
     215     CALL crs_dom_sfc( umask, 'U', e2e3u, e2e3u_msk, p_e2=e2u, p_e3=zfse3u ) 
     216     CALL crs_dom_sfc( vmask, 'V', e1e3v, e1e3v_msk, p_e1=e1v, p_e3=zfse3v ) 
    221217    
     218     facsurfu(:,:,:) = umask_crs(:,:,:) * e2e3u_msk(:,:,:) / e2e3u(:,:,:) 
     219     facsurfv(:,:,:) = vmask_crs(:,:,:) * e1e3v_msk(:,:,:) / e1e3v(:,:,:) 
    222220 
    223221     !--------------------------------------------------------- 
    … …  
    227225 
    228226!!     ! jes. May not need ocean_volume_crs_t, ocean_volume_crs_w as calculated already in trc_init as cvol 
    229       CALL crsfun_wgt( cd_type='T', cd_op='VOL', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3t, & 
    230          &             p_cfield3d_1=ocean_volume_crs_t, p_cfield3d_2=facvol_t ) 
    231        
    232       r1_bt_crs(:,:,:) = 0._wp  
    233       bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:)* facvol_t(:,:,:) 
    234       WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp/bt_crs(:,:,:) 
    235  
    236       CALL crsfun_wgt( cd_type='W', cd_op='VOL', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3w, & 
    237          &             p_cfield3d_1=ocean_volume_crs_w, p_cfield3d_2=facvol_w ) 
    238  
    239      ! 4.c. T volume weights 
    240       CALL crsfun_wgt( cd_type='T', cd_op='WGT', p_pmask=tmask, p_e1=e1t, p_e2=e2t, p_fse3=zfse3t, p_cfield3d_1=crs_volt_wgt )   
    241  
     227     CALL crs_dom_facvol( tmask, 'T', e1t, e2t, zfse3t, ocean_volume_crs_t, facvol_t ) 
     228     ! 
     229     bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:) 
     230     ! 
     231     r1_bt_crs(:,:,:) = 0._wp  
     232     WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp / bt_crs(:,:,:) 
     233 
     234     CALL crs_dom_facvol( tmask, 'W', e1t, e2t, zfse3w, ocean_volume_crs_w, facvol_w ) 
     235     ! 
    242236     !--------------------------------------------------------- 
    243237     ! 5.  Write out coarse meshmask  (see OPA_SRC/DOM/domwri.F90 for ideas later) 

  • branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsiom.F90

    r3864 r3895  
    3131   !! jes. 28 Jun 2012. TODO. make sure of variable declarations to be placed here or crs_dom.F90 
    3232   !!-------------------------------------------------------------------- 
     33   USE timing 
     34   USE crs 
    3335   USE dom_oce         ! ocean space and time domain 
    34    USE crs 
     36   USE iom_def         ! iom variables definitions 
     37   USE netcdf          ! NetCDF library 
    3538   USE in_out_manager  ! I/O manager 
     39   USE lib_mpp         ! MPP library 
    3640   USE iom             ! I/O library 
     41   USE par_kind, ONLY: wp    
    3742 
    3843 
    … …  
    4045   PRIVATE 
    4146 
    42    PUBLIC crs_iom_open, crs_iom_rstput, crs_iom_put 
     47   PUBLIC crs_iom_open, crs_iom_close, crs_iom_rstput, crs_iom_put 
     48 
     49!   PUBLIC crs_iom_varid, crs_iom_get, crs_iom_gettime 
     50 
     51 
     52   INTEGER, PARAMETER ::   jpdomcrs_data          = 1   !: ( 1  :jpiglo_crs, 1  :jpjglo_crs) 
     53   INTEGER, PARAMETER ::   jpdomcrs_global        = 2   !: ( 1  :jpiglo_crs, 1  :jpjglo_crs) 
     54   INTEGER, PARAMETER ::   jpdomcrs_local         = 3   !: One of the 3 following cases 
     55   INTEGER, PARAMETER ::   jpdomcrs_local_full    = 4   !: ( 1  :jpi_crs   , 1  :jpj_crs   ) 
     56   INTEGER, PARAMETER ::   jpdomcrs_local_noextra = 5   !: ( 1  :nlci_crs  , 1  :nlcj_crs  ) 
     57   INTEGER, PARAMETER ::   jpdomcrs_local_noovlap = 6   !: (nldi_crs:nlei_crs  ,nldj_crs:nlej_crs  ) 
     58   INTEGER, PARAMETER ::   jpdomcrs_unknown       = 7   !: No dimension checking 
     59   INTEGER, PARAMETER ::   jpdomcrs_autoglo       = 8   !: 
     60   INTEGER, PARAMETER ::   jpdomcrs_autodta       = 9   !: 
     61   INTEGER            ::   ipdomcrs_local_noovlap_crs, ipdomcrs_local_full_crs, idomcrs_local_noextra_crs 
    4362 
    4463   INTEGER                 ::   idomcrs     ! Type of domain to be written (default = jpdom_local_noovlap) 
     64   INTEGER, DIMENSION(2,5) ::   idompar_crs ! domain parameters:     
    4565   LOGICAL                 ::   llnoov      ! local definition to read overlap 
    4666 
    … …  
    6585 
    6686      llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif  
    67       IF( llnoov ) THEN   ;   idomcrs = jpdom_local_noovlap   ! default definition 
    68       ELSE                ;   idomcrs = jpdom_local_full      ! default definition 
     87      IF( llnoov ) THEN   ;   idomcrs = jpdomcrs_local_noovlap   ! default definition 
     88      ELSE                ;   idomcrs = jpdomcrs_local_full      ! default definition 
    6989      ENDIF 
    7090      IF ( PRESENT(kdom) ) idomcrs = kdom 
    … …  
    7292      CALL iom_open( cdname, kiomid, ldwrt, idomcrs, kiolib ) 
    7393 
     94      WRITE(numout,*) 'crs_iom_open. after iom_open call kiomid=', kiomid 
     95 
    7496      CALL dom_grid_glo   ! Return to parent grid domain 
    7597 
    7698   END SUBROUTINE crs_iom_open 
     99 
     100 
     101   SUBROUTINE crs_iom_close( kiomid ) 
     102      !!-------------------------------------------------------------------- 
     103      !!                       ***  MODULE crs_iom_open  *** 
     104      !! 
     105      !! ** Purpose : open an input file with NF90 on coarsened grid 
     106      !!--------------------------------------------------------------------- 
     107      !! Arguments 
     108      INTEGER                , INTENT(inout)           ::   kiomid      ! nf90 identifier of the opened file 
     109      !! Local variable 
     110      CHARACTER(LEN=100)  ::   clinfo   ! info character 
     111      !--------------------------------------------------------------------- 
     112      ! 
     113      WRITE(numout,*) 'crs_iom_close. kiomid=', kiomid 
     114 
     115      CALL iom_close( kiomid ) 
     116      WRITE(numout,*) 'crs_iom_close. after iom_open call kiomid=', kiomid 
     117 
     118      !     
     119   END SUBROUTINE crs_iom_close 
    77120 
    78121 
    … …  
    137180      ELSEIF( PRESENT(pv_r3d) ) THEN   ;  CALL iom_put( cdvar, pv_r3d ) 
    138181      ENDIF 
    139  
    140182      CALL dom_grid_glo   ! Return to parent grid domain 
    141183 
Note: See TracChangeset for help on using the changeset viewer.