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 13228 for NEMO/branches – NEMO

Changeset 13228 for NEMO/branches


Ignore:
Timestamp:
2020-07-02T16:41:07+02:00 (4 years ago)
Author:
smasson
Message:

better e3: update with trunk@13227 see #2385

Location:
NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3
Files:
123 edited
4 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ABL/ablmod.F90

    r13219 r13228  
    529529      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    530530      ! 
    531       CALL lbc_lnk_multi( 'ablmod',  u_abl(:,:,:,nt_a      ), 'T', -1.,  v_abl(:,:,:,nt_a)      , 'T', -1.                            ) 
    532       CALL lbc_lnk_multi( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T',  1., tq_abl(:,:,:,nt_a,jp_qa), 'T',  1., kfillmode = jpfillnothing )   ! ++++ this should not be needed... 
     531      CALL lbc_lnk_multi( 'ablmod',  u_abl(:,:,:,nt_a      ), 'T', -1._wp,  v_abl(:,:,:,nt_a)      , 'T', -1._wp                            ) 
     532      CALL lbc_lnk_multi( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T', 1._wp , tq_abl(:,:,:,nt_a,jp_qa), 'T',  1._wp , kfillmode = jpfillnothing )   ! ++++ this should not be needed... 
    533533      ! 
    534534#if defined key_iomput 
    … …  
    594594      END_2D 
    595595      ! 
    596       CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1., zwnd_j(:,:) , 'T', -1. ) 
     596      CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1.0_wp, zwnd_j(:,:) , 'T', -1.0_wp ) 
    597597      ! 
    598598      ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) 
    … …  
    619619      END_2D 
    620620      ! 
    621       CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1., ptauj(:,:), 'V', -1. ) 
     621      CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1.0_wp, ptauj(:,:), 'V', -1.0_wp ) 
    622622 
    623623      CALL iom_put( "taum_oce", ptaum ) 
    … …  
    639639            &                      * ( 0.5_wp * ( v_abl(ji,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) ) - pssv_ice(ji,jj) ) 
    640640      END_2D 
    641       CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1., ptauj_ice, 'V', -1. ) 
     641      CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice, 'V', -1.0_wp ) 
    642642      ! 
    643643      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=ptaui_ice  , clinfo1=' abl_stp: putaui : '   & 
    … …  
    658658            &         * ( zztmp2 - pssv_ice(ji,jj) ) 
    659659      END_2D 
    660       CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1., ptauj_ice, 'V', -1. ) 
     660      CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice,'V', -1.0_wp ) 
    661661      ! 
    662662      IF(sn_cfctl%l_prtctl) THEN 
    … …  
    865865      ! Optional : could add pblh smoothing if pblh is noisy horizontally ... 
    866866      IF(ln_smth_pblh) THEN 
    867          CALL lbc_lnk( 'ablmod', pblh, 'T', 1.) !, kfillmode = jpfillnothing) 
     867         CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing) 
    868868         CALL smooth_pblh( pblh, msk_abl ) 
    869          CALL lbc_lnk( 'ablmod', pblh, 'T', 1.) !, kfillmode = jpfillnothing) 
     869         CALL lbc_lnk( 'ablmod', pblh, 'T', 1.0_wp) !, kfillmode = jpfillnothing) 
    870870      ENDIF 
    871871      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    … …  
    958958               DO ji = 1, jpi 
    959959                  zbuoy    = MAX( zbn2(ji, jj, jk), rsmall ) 
    960                   zcff     = 2.*SQRT(tke_abl( ji, jj, jk, nt_a )) / ( rn_Rod*zsh2(ji,jk) & 
    961                                 &             + SQRT( rn_Rod*rn_Rod*zsh2(ji,jk)*zsh2(ji,jk)+2.*zbuoy ) ) 
     960                  zcff     = 2.0_wp*SQRT(tke_abl( ji, jj, jk, nt_a )) / ( rn_Rod*zsh2(ji,jk) & 
     961                                &             + SQRT(rn_Rod*rn_Rod*zsh2(ji,jk)*zsh2(ji,jk)+2.0_wp*zbuoy ) ) 
    962962                                  mxlm_abl( ji, jj, jk ) = MAX( mxl_min, zcff ) 
    963963               END DO 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icecor.F90

    r12724 r13228  
    114114            ENDIF 
    115115         END_2D 
    116          CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. ) 
     116         CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) 
    117117      ENDIF 
    118118 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn.F90

    r12377 r13228  
    129129            zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
    130130            zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
    131             u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
    132             v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
     131            u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
     132            v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
    133133         END_2D 
    134134         ! --- 
    … …  
    159159                  &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 
    160160            END_2D 
    161             CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. ) 
     161            CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1.0_wp ) 
    162162            ! output 
    163163            CALL iom_put( 'icediv' , zdivu_i ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_adv_pra.F90

    r12724 r13228  
    117117         END_2D 
    118118      END DO 
    119       CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. ) 
     119      CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 
    120120      ! 
    121121      ! --- If ice drift is too fast, use  subtime steps for advection (CFL test for stability) --- ! 
    … …  
    254254               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
    255255         END_2D 
    256          CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T',  1. ) 
     256         CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T',  1.0_wp ) 
    257257         ! 
    258258         ! --- Ensure non-negative fields --- ! 
    … …  
    425425 
    426426      !-- Lateral boundary conditions 
    427       CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T',  1., ps0 , 'T',  1.   & 
    428          &                                , psx             , 'T', -1., psy , 'T', -1.   &   ! caution gradient ==> the sign changes 
    429          &                                , psxx            , 'T',  1., psyy, 'T',  1. , psxy, 'T',  1. ) 
     427      CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T',  1.0_wp, ps0 , 'T',  1.0_wp   & 
     428         &                                , psx             , 'T', -1.0_wp, psy , 'T', -1.0_wp   &   ! caution gradient ==> the sign changes 
     429         &                                , psxx            , 'T',  1.0_wp, psyy, 'T',  1.0_wp , psxy, 'T',  1.0_wp ) 
    430430      ! 
    431431   END SUBROUTINE adv_x 
    … …  
    584584 
    585585      !-- Lateral boundary conditions 
    586       CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T',  1., ps0 , 'T',  1.   & 
    587          &                                , psx             , 'T', -1., psy , 'T', -1.   &   ! caution gradient ==> the sign changes 
    588          &                                , psxx            , 'T',  1., psyy, 'T',  1. , psxy, 'T',  1. ) 
     586      CALL lbc_lnk_multi( 'icedyn_adv_pra', psm(:,:,1:jcat) , 'T',  1.0_wp, ps0 , 'T',  1.0_wp   & 
     587         &                                , psx             , 'T', -1.0_wp, psy , 'T', -1.0_wp   &   ! caution gradient ==> the sign changes 
     588         &                                , psxx            , 'T',  1.0_wp, psyy, 'T',  1.0_wp , psxy, 'T',  1.0_wp ) 
    589589      ! 
    590590   END SUBROUTINE adv_y 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_adv_umx.F90

    r12724 r13228  
    122122         END_2D 
    123123      END DO 
    124       CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. ) 
     124      CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 
    125125      ! 
    126126      ! 
    … …  
    336336               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
    337337         END_2D 
    338          CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T',  1. ) 
     338         CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T',  1.0_wp ) 
    339339         ! 
    340340         ! 
    … …  
    469469            END_2D 
    470470         END DO 
    471          CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T',  1. ) 
     471         CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T',  1.0_wp ) 
    472472         ! 
    473473         IF    ( np_limiter == 1 ) THEN 
    … …  
    500500         END_2D 
    501501      END DO 
    502       CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T',  1. ) 
     502      CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T',  1.0_wp ) 
    503503      ! 
    504504   END SUBROUTINE adv_umx 
    … …  
    552552               END_2D 
    553553            END DO 
    554             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     554            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 
    555555            ! 
    556556            DO jl = 1, jpl              !-- flux in y-direction 
    … …  
    576576               END_2D 
    577577            END DO 
    578             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     578            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 
    579579            ! 
    580580            DO jl = 1, jpl              !-- flux in x-direction 
    … …  
    598598         END_2D 
    599599      END DO 
    600       CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1. ) 
     600      CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1.0_wp ) 
    601601 
    602602   END SUBROUTINE upstream 
    … …  
    660660               END_2D 
    661661            END DO 
    662             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     662            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 
    663663 
    664664            DO jl = 1, jpl              !-- flux in y-direction 
    … …  
    686686               END_2D 
    687687            END DO 
    688             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     688            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 
    689689            ! 
    690690            DO jl = 1, jpl              !-- flux in x-direction 
    … …  
    744744            END_2D 
    745745         END DO 
    746          CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     746         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 
    747747         ! 
    748748         !                                                        !--  ultimate interpolation of pt at v-point  --! 
    … …  
    771771            END_2D 
    772772         END DO 
    773          CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     773         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1.0_wp ) 
    774774         ! 
    775775         !                                                        !--  ultimate interpolation of pt at u-point  --! 
    … …  
    824824         END DO 
    825825      END DO 
    826       CALL lbc_lnk( 'icedyn_adv_umx', ztu2, 'T', 1. ) 
     826      CALL lbc_lnk( 'icedyn_adv_umx', ztu2, 'T', 1.0_wp ) 
    827827      ! 
    828828      !                                                     !--  BiLaplacian in i-direction  --! 
    … …  
    838838         END DO 
    839839      END DO 
    840       CALL lbc_lnk( 'icedyn_adv_umx', ztu4, 'T', 1. ) 
     840      CALL lbc_lnk( 'icedyn_adv_umx', ztu4, 'T', 1.0_wp ) 
    841841      ! 
    842842      ! 
    … …  
    964964         END_2D 
    965965      END DO 
    966       CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1. ) 
     966      CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1.0_wp ) 
    967967      ! 
    968968      !                                                     !--  BiLaplacian in j-direction  --! 
    … …  
    975975         END_2D 
    976976      END DO 
    977       CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1. ) 
     977      CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1.0_wp ) 
    978978      ! 
    979979      ! 
    … …  
    11141114            END_2D 
    11151115         END DO 
    1116          CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1., ztj_ups, 'T', 1. ) 
     1116         CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1.0_wp, ztj_ups, 'T', 1.0_wp ) 
    11171117 
    11181118         DO jl = 1, jpl 
    … …  
    11361136            END_2D 
    11371137         END DO 
    1138          CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1., pfv_ho, 'V', -1. )   ! lateral boundary cond. 
     1138         CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp, pfv_ho, 'V', -1.0_wp )   ! lateral boundary cond. 
    11391139 
    11401140      ENDIF 
    … …  
    11931193         END_2D 
    11941194      END DO 
    1195       CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1., zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign) 
     1195      CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1.0_wp, zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
    11961196 
    11971197       
    … …  
    12481248         END_2D 
    12491249      END DO 
    1250       CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.)   ! lateral boundary cond. 
     1250      CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.0_wp)   ! lateral boundary cond. 
    12511251       
    12521252      DO jl = 1, jpl 
    … …  
    13121312         END_2D 
    13131313      END DO 
    1314       CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.)   ! lateral boundary cond. 
     1314      CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp)   ! lateral boundary cond. 
    13151315      ! 
    13161316   END SUBROUTINE limiter_x 
    … …  
    13391339         END_2D 
    13401340      END DO 
    1341       CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.)   ! lateral boundary cond. 
     1341      CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.0_wp)   ! lateral boundary cond. 
    13421342 
    13431343      DO jl = 1, jpl 
    … …  
    14041404         END_2D 
    14051405      END DO 
    1406       CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.)   ! lateral boundary cond. 
     1406      CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.0_wp)   ! lateral boundary cond. 
    14071407      ! 
    14081408   END SUBROUTINE limiter_y 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_rdgrft.F90

    r12724 r13228  
    300300 
    301301      !                       ! Ice thickness needed for rafting 
     302      ! In single precision there were floating point invalids due a sqrt of zhi which happens to have negative values 
     303      ! To solve that an extra check about the value of pv_i was added. 
     304      ! Although adding this condition is safe, the double definition (one for single other for double) has been kept to preserve the results of the sette test. 
     305#if defined key_single 
     306 
     307      WHERE( pa_i(1:npti,:) > epsi10 .and. pv_i(1:npti,:) > epsi10 )   ;   zhi(1:npti,:) = pv_i(1:npti,:) / pa_i(1:npti,:) 
     308#else 
    302309      WHERE( pa_i(1:npti,:) > epsi10 )   ;   zhi(1:npti,:) = pv_i(1:npti,:) / pa_i(1:npti,:) 
     310#endif 
    303311      ELSEWHERE                          ;   zhi(1:npti,:) = 0._wp 
    304312      END WHERE 
    … …  
    780788            strength(ji,jj) = zworka(ji,jj) 
    781789         END_2D 
    782          CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 
     790         CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) 
    783791         ! 
    784792      CASE( 2 )               !--- Temporal smoothing 
    … …  
    799807            ENDIF 
    800808         END_2D 
    801          CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 
     809         CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1.0_wp ) 
    802810         ! 
    803811      END SELECT 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icedyn_rhg_evp.F90

    r12731 r13228  
    300300 
    301301      END_2D 
    302       CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1., zdt_m, 'T', 1. ) 
     302      CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 
    303303      ! 
    304304      !                                  !== Landfast ice parameterization ==! 
    … …  
    319319            tau_icebfr(ji,jj) = - rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
    320320         END_2D 
    321          CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1. ) 
     321         CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1.0_wp ) 
    322322         ! 
    323323      ELSE                               !-- no landfast 
    … …  
    353353 
    354354         END_2D 
    355          CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1. ) 
     355         CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1.0_wp ) 
    356356 
    357357         DO_2D_01_01 
    … …  
    395395           
    396396         END_2D 
    397          CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1. ) 
     397         CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1.0_wp ) 
    398398 
    399399         DO_2D_10_10 
    … …  
    484484               ENDIF 
    485485            END_2D 
    486             CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 
     486            CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) 
    487487            ! 
    488488#if defined key_agrif 
    … …  
    533533               ENDIF 
    534534            END_2D 
    535             CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 
     535            CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) 
    536536            ! 
    537537#if defined key_agrif 
    … …  
    584584               ENDIF 
    585585            END_2D 
    586             CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 
     586            CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1.0_wp ) 
    587587            ! 
    588588#if defined key_agrif 
    … …  
    633633               ENDIF 
    634634            END_2D 
    635             CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 
     635            CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1.0_wp ) 
    636636            ! 
    637637#if defined key_agrif 
    … …  
    694694 
    695695      END_2D 
    696       CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. ) 
     696      CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp ) 
    697697       
    698698      ! --- Store the stress tensor for the next time step --- ! 
    699       CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1., zs2, 'T', 1., zs12, 'F', 1. ) 
     699      CALL lbc_lnk_multi( 'icedyn_rhg_evp', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp ) 
    700700      pstress1_i (:,:) = zs1 (:,:) 
    701701      pstress2_i (:,:) = zs2 (:,:) 
    … …  
    714714         & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 
    715715         ! 
    716          CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1., ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1., & 
    717             &                                  ztaux_bi, 'U', -1., ztauy_bi, 'V', -1. ) 
     716         CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, & 
     717            &                                  ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 
    718718         ! 
    719719         CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) 
    … …  
    752752            zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 
    753753         END_2D 
    754          CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1., zsig2, 'T', 1., zsig3, 'T', 1. ) 
     754         CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1.0_wp, zsig2, 'T', 1.0_wp, zsig3, 'T', 1.0_wp ) 
    755755         ! 
    756756         CALL iom_put( 'isig1' , zsig1 ) 
    … …  
    769769         & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 
    770770         ! 
    771          CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1., zspgV, 'V', -1., & 
    772             &                                  zCorU, 'U', -1., zCorV, 'V', -1., zfU, 'U', -1., zfV, 'V', -1. ) 
     771         CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 
     772            &                                  zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 
    773773 
    774774         CALL iom_put( 'dssh_dx' , zspgU * zmsk00 )   ! Sea-surface tilt term in force balance (x) 
    … …  
    802802         END_2D 
    803803 
    804          CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., & 
    805             &                                  zdiag_xmtrp_snw, 'U', -1., zdiag_ymtrp_snw, 'V', -1., & 
    806             &                                  zdiag_xatrp    , 'U', -1., zdiag_yatrp    , 'V', -1. ) 
     804         CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 
     805            &                                  zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 
     806            &                                  zdiag_xatrp    , 'U', -1.0_wp, zdiag_yatrp    , 'V', -1.0_wp ) 
    807807 
    808808         CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice )   ! X-component of sea-ice mass transport (kg/s) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/iceitd.F90

    r12377 r13228  
    148148               !    Note: hn(t+1) must not be too close to either HR or HL otherwise a division by nearly 0 is possible  
    149149               !          in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) 
     150# if defined key_single 
     151               IF( a_i_2d(ji,jl  ) > epsi10 .AND. h_i_2d(ji,jl  ) > ( zhbnew(ji,jl) - epsi06 ) )   nptidx(ji) = 0 
     152               IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi06 ) )   nptidx(ji) = 0 
     153# else 
    150154               IF( a_i_2d(ji,jl  ) > epsi10 .AND. h_i_2d(ji,jl  ) > ( zhbnew(ji,jl) - epsi10 ) )   nptidx(ji) = 0 
    151155               IF( a_i_2d(ji,jl+1) > epsi10 .AND. h_i_2d(ji,jl+1) < ( zhbnew(ji,jl) + epsi10 ) )   nptidx(ji) = 0 
     156# endif 
    152157               ! 
    153158               ! 2) Hn-1 < Hn* < Hn+1   
    … …  
    170175            !    h1(t) must not be too close to either HR or HL otherwise a division by nearly 0 is possible  
    171176            !    in itd_glinear in the case (HR-HL) = 3(Hice - HL) or = 3(HR - Hice) 
     177# if defined key_single 
     178            IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi06 ) )   nptidx(ji) = 0 
     179            IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi06 ) )   nptidx(ji) = 0 
     180# else 
    172181            IF( h_ib_2d(ji,1) < ( hi_max(0) + epsi10 ) )   nptidx(ji) = 0 
    173182            IF( h_ib_2d(ji,1) > ( hi_max(1) - epsi10 ) )   nptidx(ji) = 0 
     183# endif 
    174184         END DO 
    175185         ! 
    … …  
    538548      ! 4) Update ice thickness and temperature 
    539549      !------------------------------------------------------------------------------- 
     550# if defined key_single 
     551      WHERE( a_i_2d(1:npti,:) >= epsi06 ) 
     552# else 
    540553      WHERE( a_i_2d(1:npti,:) >= epsi20 ) 
     554# endif 
    541555         h_i_2d (1:npti,:)  =  v_i_2d(1:npti,:) / a_i_2d(1:npti,:)  
    542556         t_su_2d(1:npti,:)  =  zaTsfn(1:npti,:) / a_i_2d(1:npti,:)  

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icesbc.F90

    r12377 r13228  
    8686            vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
    8787         END_2D 
    88          CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 
     88         CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) 
    8989      ENDIF 
    9090      ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd.F90

    r12724 r13228  
    121121         END_2D 
    122122      ENDIF 
    123       CALL lbc_lnk( 'icethd', zfric, 'T',  1. ) 
     123      CALL lbc_lnk( 'icethd', zfric, 'T',  1.0_wp ) 
    124124      ! 
    125125      !--------------------------------------------------------------------! 
    … …  
    218218                              CALL ice_thd_dh                           ! Ice-Snow thickness    
    219219                              CALL ice_thd_pnd                          ! Melt ponds formation 
    220                               CALL ice_thd_ent( e_i_1d(1:npti,:) )      ! Ice enthalpy remapping 
     220                              CALL ice_thd_ent( e_i_1d(1:npti,:), .true. )      ! Ice enthalpy remapping 
    221221            ENDIF 
    222222                              CALL ice_thd_sal( ln_icedS )          ! --- Ice salinity --- !     

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd_dh.F90

    r12724 r13228  
    186186      ! Snow precipitation 
    187187      !------------------- 
    188       CALL ice_thd_snwblow( 1. - at_i_1d(1:npti), zsnw(1:npti) )   ! snow distribution over ice after wind blowing 
     188      CALL ice_thd_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) )   ! snow distribution over ice after wind blowing 
    189189 
    190190      zdeltah(1:npti,:) = 0._wp 
    … …  
    442442                
    443443               zEi           = rcpi * ( zt_i_new - (ztmelts+rt0) ) &                                  ! Specific enthalpy of forming ice (J/kg, <0) 
    444                   &            - rLfus * ( 1.0 - ztmelts / ( zt_i_new - rt0 ) ) + rcp  * ztmelts 
     444                  &            - rLfus * ( 1.0 - ztmelts / ( MIN( zt_i_new - rt0, -epsi10 ) ) ) + rcp  * ztmelts 
    445445 
    446446               zEw           = rcp  * ( t_bo_1d(ji) - rt0 )                                           ! Specific enthalpy of seawater (J/kg, < 0) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd_do.F90

    r12724 r13228  
    191191         END_2D 
    192192         !  
    193          CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1., ht_i_new, 'T', 1.  ) 
     193         CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp  ) 
    194194 
    195195      ENDIF 
    … …  
    385385            END DO 
    386386            ! --- Ice enthalpy remapping --- ! 
    387             CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) )  
     387            CALL ice_thd_ent( ze_i_2d(1:npti,:,jl), .false. )  
    388388         END DO 
    389389 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icethd_ent.F90

    r12724 r13228  
    3838CONTAINS 
    3939  
    40    SUBROUTINE ice_thd_ent( qnew ) 
     40   SUBROUTINE ice_thd_ent( qnew, compute_hfx_err ) 
    4141      !!------------------------------------------------------------------- 
    4242      !!               ***   ROUTINE ice_thd_ent  *** 
    … …  
    6464      !!------------------------------------------------------------------- 
    6565      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   qnew             ! new enthlapies (J.m-3, remapped) 
     66      LOGICAL, INTENT(in)                     ::   compute_hfx_err  ! determines whether to compute diag. 
     67                                                                    ! error or not 
    6668      ! 
    6769      INTEGER  :: ji         !  dummy loop indices 
    … …  
    128130      ! comment: if input h_i_old and eh_i_old are already multiplied by a_i (as in icethd_do),  
    129131      ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0 
    130       DO ji = 1, npti 
    131          hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice *  & 
    132             &               ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) )  
    133       END DO 
    134        
     132      IF( compute_hfx_err ) THEN 
     133         DO ji = 1, npti 
     134            hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice *  & 
     135               &               ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) 
     136         END DO 
     137      END IF 
     138  
    135139   END SUBROUTINE ice_thd_ent 
    136140 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/iceupdate.F90

    r12724 r13228  
    342342            tmod_io(ji,jj) = zrhoco * SQRT( zmodt )          ! rhoco * |U_ice-U_oce| at T-point 
    343343         END_2D 
    344          CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1., tmod_io, 'T', 1. ) 
     344         CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp ) 
    345345         ! 
    346346         utau_oce(:,:) = utau(:,:)                    !* save the air-ocean stresses at ice time-step 
    … …  
    364364         vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 
    365365      END_2D 
    366       CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1., vtau, 'V', -1. )   ! lateral boundary condition 
     366      CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp )   ! lateral boundary condition 
    367367      ! 
    368368      IF( ln_timing )   CALL timing_stop('ice_update_tau') 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icevar.F90

    r12724 r13228  
    635635      !!------------------------------------------------------------------- 
    636636      ! 
    637       WHERE( pa_i (1:npti,:)   < 0._wp .AND. pa_i (1:npti,:)   > -epsi10 )   pa_i (1:npti,:)   = 0._wp   !  a_i must be >= 0 
    638       WHERE( pv_i (1:npti,:)   < 0._wp .AND. pv_i (1:npti,:)   > -epsi10 )   pv_i (1:npti,:)   = 0._wp   !  v_i must be >= 0 
    639       WHERE( pv_s (1:npti,:)   < 0._wp .AND. pv_s (1:npti,:)   > -epsi10 )   pv_s (1:npti,:)   = 0._wp   !  v_s must be >= 0 
    640       WHERE( psv_i(1:npti,:)   < 0._wp .AND. psv_i(1:npti,:)   > -epsi10 )   psv_i(1:npti,:)   = 0._wp   ! sv_i must be >= 0 
    641       WHERE( poa_i(1:npti,:)   < 0._wp .AND. poa_i(1:npti,:)   > -epsi10 )   poa_i(1:npti,:)   = 0._wp   ! oa_i must be >= 0 
    642       WHERE( pe_i (1:npti,:,:) < 0._wp .AND. pe_i (1:npti,:,:) > -epsi06 )   pe_i (1:npti,:,:) = 0._wp   !  e_i must be >= 0 
    643       WHERE( pe_s (1:npti,:,:) < 0._wp .AND. pe_s (1:npti,:,:) > -epsi06 )   pe_s (1:npti,:,:) = 0._wp   !  e_s must be >= 0 
     637 
     638      WHERE( pa_i (1:npti,:)   < 0._wp )   pa_i (1:npti,:)   = 0._wp   !  a_i must be >= 0 
     639      WHERE( pv_i (1:npti,:)   < 0._wp )   pv_i (1:npti,:)   = 0._wp   !  v_i must be >= 0 
     640      WHERE( pv_s (1:npti,:)   < 0._wp )   pv_s (1:npti,:)   = 0._wp   !  v_s must be >= 0 
     641      WHERE( psv_i(1:npti,:)   < 0._wp )   psv_i(1:npti,:)   = 0._wp   ! sv_i must be >= 0 
     642      WHERE( poa_i(1:npti,:)   < 0._wp )   poa_i(1:npti,:)   = 0._wp   ! oa_i must be >= 0 
     643      WHERE( pe_i (1:npti,:,:) < 0._wp )   pe_i (1:npti,:,:) = 0._wp   !  e_i must be >= 0 
     644      WHERE( pe_s (1:npti,:,:) < 0._wp )   pe_s (1:npti,:,:) = 0._wp   !  e_s must be >= 0 
    644645      IF( ln_pnd_H12 ) THEN 
    645          WHERE( pa_ip(1:npti,:) < 0._wp .AND. pa_ip(1:npti,:) > -epsi10 )    pa_ip(1:npti,:)   = 0._wp   ! a_ip must be >= 0 
    646          WHERE( pv_ip(1:npti,:) < 0._wp .AND. pv_ip(1:npti,:) > -epsi10 )    pv_ip(1:npti,:)   = 0._wp   ! v_ip must be >= 0 
     646         WHERE( pa_ip(1:npti,:) < 0._wp )    pa_ip(1:npti,:)   = 0._wp   ! a_ip must be >= 0 
     647         WHERE( pv_ip(1:npti,:) < 0._wp )    pv_ip(1:npti,:)   = 0._wp   ! v_ip must be >= 0 
    647648      ENDIF 
    648649      ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/ICE/icewri.F90

    r12724 r13228  
    135135            z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 
    136136         END_2D 
    137          CALL lbc_lnk( 'icewri', z2d, 'T', 1. ) 
     137         CALL lbc_lnk( 'icewri', z2d, 'T', 1.0_wp ) 
    138138         CALL iom_put( 'icevel', z2d ) 
    139139 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/NST/agrif_oce_sponge.F90

    r13219 r13228  
    295295            fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) ) * ssvmask(ji,jj) 
    296296         END_2D 
    297          CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1. )   ! Lateral boundary conditions 
    298          CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1. ) 
     297         CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1.0_wp )   ! Lateral boundary conditions 
     298         CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1.0_wp ) 
    299299 
    300300         spongedoneT = .TRUE. 
    … …  
    311311                                  &  * ssvmask(ji,jj) * ssvmask(ji,jj+1) 
    312312         END_2D 
    313          CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1. )   ! Lateral boundary conditions 
    314          CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1. ) 
     313         CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1.0_wp )   ! Lateral boundary conditions 
     314         CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1.0_wp ) 
    315315          
    316316         spongedoneU = .TRUE. 
    … …  
    334334      END_2D 
    335335      ! 
    336       ztabramp(:,:) = REAL( mbkt_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1. ) 
     336      ztabramp(:,:) = REAL( mbkt_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1.0_wp ) 
    337337      mbkt_parent(:,:) = NINT( ztabramp(:,:) ) 
    338       ztabramp(:,:) = REAL( mbku_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1. ) 
     338      ztabramp(:,:) = REAL( mbku_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1.0_wp ) 
    339339      mbku_parent(:,:) = NINT( ztabramp(:,:) ) 
    340       ztabramp(:,:) = REAL( mbkv_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1. ) 
     340      ztabramp(:,:) = REAL( mbkv_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1.0_wp ) 
    341341      mbkv_parent(:,:) = NINT( ztabramp(:,:) ) 
    342342#endif 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/NST/agrif_user.F90

    r13219 r13228  
    271271      ENDIF 
    272272      ! 
    273       CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1. ) 
    274       CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1. ) 
    275       zk(:,:) = REAL( mbku_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1. ) 
     273      CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp ) 
     274      CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1.0_wp ) 
     275      zk(:,:) = REAL( mbku_parent(:,:), wp )   ;   CALL lbc_lnk('Agrif_InitValues_cont', zk, 'U', 1.0_wp ) 
    276276      mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) ; 
    277       zk(:,:) = REAL( mbkv_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1. ) 
     277      zk(:,:) = REAL( mbkv_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp ) 
    278278      mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 )    
    279279 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ASM/asminc.F90

    r12732 r13228  
    421421                     &            / e3t(ji,jj,jk,Kmm) 
    422422               END_2D 
    423                CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. )   ! lateral boundary cond. (no sign change) 
     423               CALL lbc_lnk( 'asminc', zhdiv, 'T', 1.0_wp )   ! lateral boundary cond. (no sign change) 
    424424               ! 
    425425               DO_2D_00_00 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdydyn2d.F90

    r11536 r13228  
    102102         END DO 
    103103         IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
    104             CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     104            CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
    105105         END IF 
    106106         IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
    107             CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     107            CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
    108108         END IF 
    109109         ! 
    … …  
    324324         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
    325325         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    326             CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T',  1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     326            CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T',  1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    327327         END IF 
    328328      END DO 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdydyn3d.F90

    r12377 r13228  
    9999         ! 
    100100         IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
    101             CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     101            CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
    102102         END IF 
    103103         IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
    104             CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     104            CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
    105105         END IF 
    106106      END DO   ! ir 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdyice.F90

    r12724 r13228  
    9494         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    9595            ! exchange 3d arrays 
    96             CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1., h_i , 'T', 1., h_s , 'T', 1., oa_i, 'T', 1. & 
    97                  &                      , a_ip, 'T', 1., v_ip, 'T', 1., s_i , 'T', 1., t_su, 'T', 1. & 
    98                  &                      , v_i , 'T', 1., v_s , 'T', 1., sv_i, 'T', 1.                & 
     96            CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1.0_wp, h_i , 'T', 1.0_wp, h_s , 'T', 1.0_wp, oa_i, 'T', 1.0_wp & 
     97                 &                      , a_ip, 'T', 1.0_wp, v_ip, 'T', 1.0_wp, s_i , 'T', 1.0_wp, t_su, 'T', 1.0_wp & 
     98                 &                      , v_i , 'T', 1.0_wp, v_s , 'T', 1.0_wp, sv_i, 'T', 1.0_wp                & 
    9999                 &                      , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1      ) 
    100100            ! exchange 4d arrays :   third dimension = 1   and then   third dimension = jpk 
    101             CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    102             CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     101            CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1.0_wp, e_s , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     102            CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1.0_wp, e_i , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    103103         END IF 
    104104      END DO   ! ir 
    … …  
    436436            END DO 
    437437            IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
    438                CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     438               CALL lbc_lnk( 'bdyice', u_ice, 'U', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
    439439            END IF 
    440440         CASE ( 'V' ) 
    … …  
    450450            END DO 
    451451            IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
    452                CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     452               CALL lbc_lnk( 'bdyice', v_ice, 'V', -1.0_wp, kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
    453453            END IF 
    454454         END SELECT 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdyini.F90

    r13193 r13228  
    638638         END DO 
    639639      END DO 
    640       CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 
     640      CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) 
    641641 
    642642      ! Read global 2D mask at T-points: bdytmask 
    … …  
    654654         END DO 
    655655      END DO 
    656       CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1. )   ! Lateral boundary cond. 
     656      CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp )   ! Lateral boundary cond.  
    657657 
    658658      ! bdy masks are now set to zero on rim 0 points: 
    … …  
    695695         END DO 
    696696      END DO 
    697       CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 
     697      CALL lbc_lnk( 'bdyini', zfmask, 'F', 1.0_wp ) 
    698698 
    699699      ! bdy masks are now set to zero on rim1 points: 
    … …  
    871871            ENDIF  
    872872            SELECT CASE( igrd ) 
    873                CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )  
    874                CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )  
    875                CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )  
     873               CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) 
     874               CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) 
     875               CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) 
    876876            END SELECT  
    877877            DO ib = ibeg, iend 
    … …  
    919919            ENDIF 
    920920            SELECT CASE( igrd ) 
    921                CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )  
    922                CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )  
    923                CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )  
     921               CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) 
     922               CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) 
     923               CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) 
    924924            END SELECT  
    925925            DO ib = ibeg, iend 
    … …  
    10071007            END DO 
    10081008            SELECT CASE( igrd ) 
    1009                CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )  
    1010                CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )  
    1011                CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )  
     1009               CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1.0_wp ) 
     1010               CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1.0_wp ) 
     1011               CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1.0_wp ) 
    10121012            END SELECT  
    10131013            DO ib = ibeg, iend 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdylib.F90

    r12724 r13228  
    249249!!$         zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1) 
    250250         ! upstream differencing for tangential derivatives 
    251          zsign_ups = sign( 1., zdt * zdy_centred ) 
     251         zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) 
    252252         zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 
    253253         zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 
    … …  
    257257         zrx = zdt * zdx / ( zex1 * znor2 )  
    258258!!$         zrx = min(zrx,2.0_wp) 
    259          zout = sign( 1., zrx ) 
     259         zout = sign( 1.0_wp, zrx ) 
    260260         zout = 0.5*( zout + abs(zout) ) 
    261261         zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) 
    … …  
    266266           &                            + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx )  
    267267         else                  !! full oblique radiation !! 
    268             zsign_ups = sign( 1., zdt * zdy ) 
     268            zsign_ups = sign( 1.0_wp, zdt * zdy ) 
    269269            zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 
    270270            zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2  
    … …  
    414414!!$            zdy_centred = phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1jm1,ijbm1jm1,jk) 
    415415            ! upstream differencing for tangential derivatives 
    416             zsign_ups = sign( 1., zdt * zdy_centred ) 
     416            zsign_ups = sign( 1.0_wp, zdt * zdy_centred ) 
    417417            zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 
    418418            zdy = zsign_ups * zdy_1 + (1. - zsign_ups) * zdy_2 
    … …  
    423423            zrx = zdt * zdx / ( zex1 * znor2 ) 
    424424!!$            zrx = min(zrx,2.0_wp) 
    425             zout = sign( 1., zrx ) 
     425            zout = sign( 1.0_wp, zrx ) 
    426426            zout = 0.5*( zout + abs(zout) ) 
    427427            zwgt = 2.*rn_Dt*( (1.-zout) * idx%nbd(jb,igrd) + zout * idx%nbdout(jb,igrd) ) 
    … …  
    432432              &                            + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx )  
    433433            else                  !! full oblique radiation !! 
    434                zsign_ups = sign( 1., zdt * zdy ) 
     434               zsign_ups = sign( 1.0_wp, zdt * zdy ) 
    435435               zsign_ups = 0.5*( zsign_ups + abs(zsign_ups) ) 
    436436               zey = zsign_ups * zey1 + (1.-zsign_ups) * zey2  

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/BDY/bdytra.F90

    r12377 r13228  
    100100         END DO 
    101101         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    102             CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T',  1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     102            CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T',  1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    103103         END IF 
    104104         ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsdom.F90

    r11536 r13228  
    8686            zmask = 0.0 
    8787            zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) )  
    88             IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 
     88            IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0_wp 
    8989                
    9090            zmask = 0.0 
    9191            zmask = SUM( vmask(ijis:ijie,je_2     ,jk) )   
    92             IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 
     92            IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0_wp 
    9393                
    9494            zmask = 0.0 
    9595            zmask = SUM(umask(ijie,ij:je_2,jk))    
    96             IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0 
     96            IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0_wp 
    9797                
    9898            fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) 
    … …  
    108108               zmask = 0.0 
    109109               zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) )  
    110                IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0 
     110               IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0_wp 
    111111                
    112112               zmask = 0.0 
    113113               zmask = SUM( vmask(ijis:ijie,ijje     ,jk) )   
    114                IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 
     114               IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0_wp 
    115115                
    116116               zmask = 0.0 
    117117               zmask = SUM( umask(ijie     ,ijjs:ijje,jk) )   
    118                IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 
     118               IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0_wp 
    119119                
    120120               fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)   
    … …  
    124124 
    125125      ! 
    126       CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) 
    127       CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) 
    128       CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) 
    129       CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) 
     126      CALL crs_lbc_lnk( tmask_crs, 'T', 1.0_wp ) 
     127      CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp ) 
     128      CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp ) 
     129      CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp ) 
    130130      ! 
    131131   END SUBROUTINE crs_dom_msk 
    … …  
    206206 
    207207      ! Retroactively add back the boundary halo cells. 
    208       CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 ) 
    209       CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 ) 
     208      CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0_wp ) 
     209      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp ) 
    210210          
    211211      ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 
    … …  
    296296      ENDDO 
    297297 
    298       CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pfillval=1.0 ) 
    299       CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pfillval=1.0 ) 
     298      CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 
     299      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 
    300300 
    301301   END SUBROUTINE crs_dom_hgr 
    … …  
    440440      ENDDO 
    441441      !                                             !  Retroactively add back the boundary halo cells. 
    442       CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 )  
    443       CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 )  
     442      CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0_wp )  
     443      CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp )  
    444444      ! 
    445445      ! 
    … …  
    17481748       ENDDO 
    17491749                   
    1750        CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pfillval=1.0 )   
    1751        CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pfillval=1.0 )   
     1750       CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0_wp, pfillval=1.0_wp )   
     1751       CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp )   
    17521752       !               
    17531753       ! 
    … …  
    18571857      ENDDO    
    18581858 
    1859       CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pfillval=1.0 ) 
    1860       CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pfillval=1.0 ) 
     1859      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0_wp, pfillval=1.0_wp ) 
     1860      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp ) 
    18611861 
    18621862   END SUBROUTINE crs_dom_sfc 
    … …  
    22462246      
    22472247      zmbk(:,:) = 0.0 
    2248       zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0)   ;   mbathy_crs(:,:) = NINT( zmbk(:,:) ) 
     2248      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0_wp)   ;   mbathy_crs(:,:) = NINT( zmbk(:,:) ) 
    22492249 
    22502250 
    … …  
    22662266      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    22672267      zmbk(:,:) = 1.e0;     
    2268       zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 )  
    2269       zmbk(:,:) = REAL( mbkv_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 )  
     2268      zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 )  
     2269      zmbk(:,:) = REAL( mbkv_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 )  
    22702270      ! 
    22712271   END SUBROUTINE crs_dom_bat 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsdomwri.F90

    r12377 r13228  
    161161         END DO    
    162162      END DO 
    163       CALL crs_lbc_lnk( zdepu,'U', 1. )   ;   CALL crs_lbc_lnk( zdepv,'V', 1. )  
     163      CALL crs_lbc_lnk( zdepu,'U', 1.0_wp )   ;   CALL crs_lbc_lnk( zdepv,'V', 1.0_wp )  
    164164      ! 
    165165      CALL iom_rstput( 0, 0, inum, 'gdepu', zdepu, ktype = jp_r4 ) 
    … …  
    222222      ! 
    223223      puniq(:,:) = ztstref(:,:)                   ! default definition 
    224       CALL crs_lbc_lnk( puniq,cdgrd, 1. )            ! apply boundary conditions 
     224      CALL crs_lbc_lnk( puniq,cdgrd, 1.0_wp )            ! apply boundary conditions 
    225225      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed  
    226226      ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsfld.F90

    r12616 r13228  
    101101      !  Temperature 
    102102      zt(:,:,:) = ts(:,:,:,jp_tem,Kmm)  ;      zt_crs(:,:,:) = 0._wp 
    103       CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) 
     103      CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 
    104104      tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) 
    105105 
    … …  
    110110      !  Salinity 
    111111      zs(:,:,:) = ts(:,:,:,jp_sal,Kmm)  ;      zs_crs(:,:,:) = 0._wp 
    112       CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) 
     112      CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 
    113113      tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) 
    114114 
    … …  
    117117 
    118118      !  U-velocity 
    119       CALL crs_dom_ope( uu(:,:,:,Kmm), 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 
     119      CALL crs_dom_ope( uu(:,:,:,Kmm), 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) 
    120120      ! 
    121121      zt(:,:,:) = 0._wp     ;    zs(:,:,:) = 0._wp  ;   zt_crs(:,:,:) = 0._wp   ;    zs_crs(:,:,:) = 0._wp 
    … …  
    124124         zs(ji,jj,jk)  = uu(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) )  
    125125      END_3D 
    126       CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 
    127       CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 
     126      CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) 
     127      CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0_wp ) 
    128128 
    129129      CALL iom_put( "uoce"  , un_crs )   ! i-current  
    … …  
    132132 
    133133      !  V-velocity 
    134       CALL crs_dom_ope( vv(:,:,:,Kmm), 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
     134      CALL crs_dom_ope( vv(:,:,:,Kmm), 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) 
    135135      !                                                                                  
    136136      zt(:,:,:) = 0._wp     ;    zs(:,:,:) = 0._wp  ;   zt_crs(:,:,:) = 0._wp   ;    zs_crs(:,:,:) = 0._wp 
    … …  
    139139         zs(ji,jj,jk)  = vv(ji,jj,jk,Kmm) * 0.5 * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) )  
    140140      END_3D 
    141       CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
    142       CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 
     141      CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) 
     142      CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0_wp ) 
    143143  
    144144      CALL iom_put( "voce"  , vn_crs )   ! i-current  
    … …  
    156156               &          + vv(ji,jj  ,jk,Kmm)**2 * e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm)   ) 
    157157         END_3D 
    158          CALL lbc_lnk( 'crsfld', z3d, 'T', 1. ) 
     158         CALL lbc_lnk( 'crsfld', z3d, 'T', 1.0_wp ) 
    159159         ! 
    160          CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) 
     160         CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 
    161161         CALL iom_put( "eken", zt_crs ) 
    162162      ENDIF 
    … …  
    176176         END DO 
    177177      END DO 
    178       CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0 ) 
     178      CALL crs_lbc_lnk( hdivn_crs, 'T', 1.0_wp ) 
    179179      ! 
    180180      CALL iom_put( "hdiv", hdivn_crs )   
    … …  
    183183      !  W-velocity 
    184184      IF( ln_crs_wn ) THEN 
    185          CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 ) 
     185         CALL crs_dom_ope( ww, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0_wp ) 
    186186       !  CALL crs_dom_ope( ww, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w ) 
    187187      ELSE 
    … …  
    197197      SELECT CASE ( nn_crs_kz ) 
    198198         CASE ( 0 ) 
    199             CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 
    200             CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 
     199            CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 
     200            CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 
    201201         CASE ( 1 ) 
    202             CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 
    203             CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 
     202            CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 
     203            CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 
    204204         CASE ( 2 ) 
    205             CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 
    206             CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 
     205            CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 
     206            CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0_wp ) 
    207207      END SELECT 
    208208      ! 
    … …  
    211211       
    212212      !  sbc fields   
    213       CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t           , psgn=1.0 )   
    214       CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u  , p_surf_crs=e2u_crs  , psgn=1.0 ) 
    215       CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v  , p_surf_crs=e1v_crs  , psgn=1.0 ) 
    216       CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
    217       CALL crs_dom_ope( rnf  , 'MAX', 'T', tmask, rnf_crs                                     , psgn=1.0 ) 
    218       CALL crs_dom_ope( qsr  , 'SUM', 'T', tmask, qsr_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
    219       CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
    220       CALL crs_dom_ope( emp  , 'SUM', 'T', tmask, emp_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
    221       CALL crs_dom_ope( sfx  , 'SUM', 'T', tmask, sfx_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
    222       CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 
     213      CALL crs_dom_ope( ssh(:,:,Kmm) , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t           , psgn=1.0_wp )   
     214      CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u  , p_surf_crs=e2u_crs  , psgn=1.0_wp ) 
     215      CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v  , p_surf_crs=e1v_crs  , psgn=1.0_wp ) 
     216      CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 
     217      CALL crs_dom_ope( rnf  , 'MAX', 'T', tmask, rnf_crs                                     , psgn=1.0_wp ) 
     218      CALL crs_dom_ope( qsr  , 'SUM', 'T', tmask, qsr_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 
     219      CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 
     220      CALL crs_dom_ope( emp  , 'SUM', 'T', tmask, emp_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 
     221      CALL crs_dom_ope( sfx  , 'SUM', 'T', tmask, sfx_crs  , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 
     222      CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0_wp ) 
    223223 
    224224      CALL iom_put( "ssh"      , sshn_crs )   ! ssh output  

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/CRS/crsini.F90

    r12680 r13228  
    211211 
    212212     !    3.d.3   Vertical depth (meters) 
    213      CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0 )  
    214      CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0 ) 
     213     CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0_wp )  
     214     CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0_wp ) 
    215215 
    216216 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DIA/diaar5.F90

    r13193 r13228  
    327327         z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk)  
    328328      END_3D 
    329        CALL lbc_lnk( 'diaar5', z2d, 'U', -1. ) 
     329       CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp ) 
    330330       IF( cptr == 'adv' ) THEN 
    331331          IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d )  ! advective heat transport in i-direction 
    … …  
    341341          z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk)  
    342342       END_3D 
    343        CALL lbc_lnk( 'diaar5', z2d, 'V', -1. ) 
     343       CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp ) 
    344344       IF( cptr == 'adv' ) THEN 
    345345          IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d )  ! advective heat transport in j-direction 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DIA/diaptr.F90

    r12724 r13228  
    570570            p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 
    571571         END_2D 
    572          CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. ) 
     572         CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp ) 
    573573      END DO 
    574574      !  

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DIA/diawri.F90

    r13198 r13228  
    207207            ! 
    208208         END_2D 
    209          CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 
     209         CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 
    210210         CALL iom_put( "taubot", z2d )            
    211211      ENDIF 
    … …  
    261261               &              * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 
    262262         END_2D 
    263          CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 
     263         CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 
    264264         CALL iom_put( "sstgrad2",  z2d )          ! square of module of sst gradient 
    265265         z2d(:,:) = SQRT( z2d(:,:) ) 
    … …  
    293293               &                     + vv(ji,jj  ,jk,Kmm)**2 * e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm)   ) 
    294294         END_3D 
    295          CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) 
     295         CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 
    296296         CALL iom_put( "eken", z3d )                 ! kinetic energy 
    297297      ENDIF 
    … …  
    315315            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) 
    316316         END_3D 
    317          CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) 
     317         CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 
    318318         CALL iom_put( "u_heattr", 0.5*rcp * z2d )    ! heat transport in i-direction 
    319319      ENDIF 
    … …  
    324324            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) 
    325325         END_3D 
    326          CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) 
     326         CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 
    327327         CALL iom_put( "u_salttr", 0.5 * z2d )        ! heat transport in i-direction 
    328328      ENDIF 
    … …  
    342342            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) 
    343343         END_3D 
    344          CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) 
     344         CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 
    345345         CALL iom_put( "v_heattr", 0.5*rcp * z2d )    !  heat transport in j-direction 
    346346      ENDIF 
    … …  
    351351            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) 
    352352         END_3D 
    353          CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) 
     353         CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 
    354354         CALL iom_put( "v_salttr", 0.5 * z2d )        !  heat transport in j-direction 
    355355      ENDIF 
    … …  
    360360            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) *  ts(ji,jj,jk,jp_tem,Kmm) 
    361361         END_3D 
    362          CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) 
     362         CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 
    363363         CALL iom_put( "tosmint", rho0 * z2d )        ! Vertical integral of temperature 
    364364      ENDIF 
    … …  
    368368            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 
    369369         END_3D 
    370          CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) 
     370         CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 
    371371         CALL iom_put( "somint", rho0 * z2d )         ! Vertical integral of salinity 
    372372      ENDIF 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/daymod.F90

    r12724 r13228  
    115115 
    116116      !compute number of days between last Monday and today 
    117       CALL ymds2ju( 1900, 01, 01, 0.0, zjul )     ! compute julian day value of 01.01.1900 (our reference that was a Monday) 
     117      CALL ymds2ju( 1900, 01, 01, 0.0_wp, zjul )     ! compute julian day value of 01.01.1900 (our reference that was a Monday) 
    118118      inbday = FLOOR(fjulday - zjul)              ! compute nb day between  01.01.1900 and start of current day 
    119119      imonday = MOD(inbday, 7)                    ! compute nb day between last monday and current day 
    … …  
    267267         ! 
    268268         !compute first day of the year in julian days 
    269          CALL ymds2ju( nyear, 01, 01, 0.0, fjulstartyear ) 
     269         CALL ymds2ju( nyear, 01, 01, 0.0_wp, fjulstartyear ) 
    270270         ! 
    271271         IF(lwp) WRITE(numout,'(a,i8,a,i4.4,a,i2.2,a,i2.2,a,i3.3)') '======>> time-step =', kt,   & 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/dommsk.F90

    r13193 r13228  
    174174         END DO 
    175175      END DO 
    176       CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1., vmask, 'V', 1., fmask, 'F', 1. )      ! Lateral boundary conditions 
     176      CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp )      ! Lateral boundary conditions 
    177177 
    178178      ! Ocean/land mask at wu-, wv- and w points    (computed from tmask) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/domwri.F90

    r12377 r13228  
    209209      ! 
    210210      puniq(:,:) = ztstref(:,:)                   ! default definition 
    211       CALL lbc_lnk( 'domwri', puniq, cdgrd, 1. )            ! apply boundary conditions 
     211      CALL lbc_lnk( 'domwri', puniq, cdgrd, 1.0_wp )            ! apply boundary conditions 
    212212      lldbl(:,:,1) = puniq(:,:) == ztstref(:,:)   ! check which values have been changed  
    213213      ! 
    … …  
    270270         END DO 
    271271      END DO 
    272       CALL lbc_lnk( 'domwri', zx1, 'T', 1. ) 
     272      CALL lbc_lnk( 'domwri', zx1, 'T', 1.0_wp ) 
    273273      ! 
    274274      IF( PRESENT( px1 ) )    px1 = zx1 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DOM/domzgr.F90

    r12377 r13228  
    322322      END_2D 
    323323      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk  
    324       zk(:,:) = REAL( miku(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'U', 1. )   ;   miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
    325       zk(:,:) = REAL( mikv(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'V', 1. )   ;   mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
    326       zk(:,:) = REAL( mikf(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'F', 1. )   ;   mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
    327       ! 
    328       zk(:,:) = REAL( mbku(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'U', 1. )   ;   mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
    329       zk(:,:) = REAL( mbkv(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'V', 1. )   ;   mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
     324      zk(:,:) = REAL( miku(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp )   ;   miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
     325      zk(:,:) = REAL( mikv(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp )   ;   mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
     326      zk(:,:) = REAL( mikf(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'F', 1.0_wp )   ;   mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
     327      ! 
     328      zk(:,:) = REAL( mbku(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'U', 1.0_wp )   ;   mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
     329      zk(:,:) = REAL( mbkv(:,:), wp )   ;   CALL lbc_lnk( 'domzgr', zk, 'V', 1.0_wp )   ;   mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
    330330      ! 
    331331   END SUBROUTINE zgr_top_bot 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/divhor.F90

    r13193 r13228  
    9494      IF( ln_isf )                      CALL isf_hdiv( kt, Kmm, hdiv )           !==  ice shelf         ==!   (update hdiv field) 
    9595      ! 
    96       CALL lbc_lnk( 'divhor', hdiv, 'T', 1. )   !   (no sign change) 
     96      CALL lbc_lnk( 'divhor', hdiv, 'T', 1.0_wp )   !   (no sign change) 
    9797      ! 
    9898      IF( ln_timing )   CALL timing_stop('div_hor') 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynadv_ubs.F90

    r12616 r13228  
    124124         END_2D 
    125125      END DO 
    126       CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1. , zlu_uv(:,:,:,1), 'U', 1.,  & 
    127                       &   zlu_uu(:,:,:,2), 'U', 1. , zlu_uv(:,:,:,2), 'U', 1.,  &  
    128                       &   zlv_vv(:,:,:,1), 'V', 1. , zlv_vu(:,:,:,1), 'V', 1.,  & 
    129                       &   zlv_vv(:,:,:,2), 'V', 1. , zlv_vu(:,:,:,2), 'V', 1.   ) 
     126      CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1.0_wp , zlu_uv(:,:,:,1), 'U', 1.0_wp,  & 
     127                      &   zlu_uu(:,:,:,2), 'U', 1.0_wp , zlu_uv(:,:,:,2), 'U', 1.0_wp,  &  
     128                      &   zlv_vv(:,:,:,1), 'V', 1.0_wp , zlv_vu(:,:,:,1), 'V', 1.0_wp,  & 
     129                      &   zlv_vv(:,:,:,2), 'V', 1.0_wp , zlv_vu(:,:,:,2), 'V', 1.0_wp   ) 
    130130      ! 
    131131      !                                      ! ====================== ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynatf.F90

    r12748 r13228  
    165165# endif 
    166166      ! 
    167       CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1., pvv(:,:,:,Kaa), 'V', -1. )     !* local domain boundaries 
     167      CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp )     !* local domain boundaries 
    168168      ! 
    169169      !                                !* BDY open boundaries 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynhpg.F90

    r12731 r13228  
    448448          END IF 
    449449        END_2D 
    450         CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) 
     450        CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
    451451      END IF 
    452452 
    … …  
    679679          END IF 
    680680        END_2D 
    681         CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) 
     681        CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
    682682      END IF 
    683683 
    … …  
    825825 
    826826      END_3D 
    827       CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1., rho_i, 'U', 1., rho_j, 'V', 1. ) 
     827      CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1.0_wp, rho_i, 'U', 1.0_wp, rho_j, 'V', 1.0_wp ) 
    828828 
    829829      ! --------------- 
    … …  
    952952            ENDIF 
    953953         END_2D 
    954          CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) 
     954         CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
    955955      ENDIF 
    956956 
    … …  
    10221022      END_2D 
    10231023 
    1024       CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1., zsshv_n, 'V', 1. ) 
     1024      CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1.0_wp, zsshv_n, 'V', 1.0_wp ) 
    10251025 
    10261026      DO_2D_00_00 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynkeg.F90

    r12377 r13228  
    121121            zhke(ji,jj,jk) = r1_48 * ( zv + zu ) 
    122122         END_3D 
    123          CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) 
     123         CALL lbc_lnk( 'dynkeg', zhke, 'T', 1.0_wp ) 
    124124         ! 
    125125      END SELECT  

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynldf_iso.F90

    r12606 r13228  
    135135         END_3D 
    136136         ! Lateral boundary conditions on the slopes 
    137          CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1., vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. ) 
     137         CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 
    138138         ! 
    139139       ENDIF 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynldf_lap_blp.F90

    r13193 r13228  
    132132      CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 )   ! rotated laplacian applied to pt (output in zlap,Kbb) 
    133133      ! 
    134       CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1., zvlap, 'V', -1. )             ! Lateral boundary conditions 
     134      CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp )             ! Lateral boundary conditions 
    135135      ! 
    136136      CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 )   ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/dynvor.F90

    r13193 r13228  
    242242         END DO 
    243243 
    244          CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) 
     244         CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    245245 
    246246      CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    … …  
    257257         END DO 
    258258 
    259          CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) 
     259         CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    260260 
    261261      END SELECT 
    … …  
    610610      END DO                                           !   End of slab 
    611611         ! 
    612       CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) 
     612      CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    613613 
    614614      DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    731731      END DO 
    732732      ! 
    733       CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) 
     733      CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    734734      ! 
    735735      DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    861861               dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji  ,jj-1) ) * 0.5_wp 
    862862            END_2D 
    863             CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1. )   ! Lateral boundary conditions 
     863            CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp )   ! Lateral boundary conditions 
    864864            ! 
    865865         CASE DEFAULT                        !* F-point metric term :   pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) 
    … …  
    869869               dj_e1u_2e1e2f(ji,jj) = ( e1u(ji  ,jj+1) - e1u(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj) 
    870870            END_2D 
    871             CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1. )   ! Lateral boundary conditions 
     871            CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp )   ! Lateral boundary conditions 
    872872         END SELECT 
    873873         ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/sshwzv.F90

    r13219 r13228  
    118118      IF ( .NOT.ln_dynspg_ts ) THEN 
    119119         IF( ln_bdy ) THEN 
    120             CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1. )    ! Not sure that's necessary 
     120            CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1.0_wp )    ! Not sure that's necessary 
    121121            CALL bdy_ssh( pssh(:,:,Kaa) )             ! Duplicate sea level across open boundaries 
    122122         ENDIF 
    … …  
    181181            END_2D 
    182182         END DO 
    183          CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.)  ! - ML - Perhaps not necessary: not used for horizontal "connexions" 
     183         CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.0_wp)  ! - ML - Perhaps not necessary: not used for horizontal "connexions" 
    184184         !                             ! Is it problematic to have a wrong vertical velocity in boundary cells? 
    185185         !                             ! Same question holds for hdiv. Perhaps just for security 
    … …  
    390390         END_3D 
    391391      ENDIF 
    392       CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. ) 
     392      CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1.0_wp ) 
    393393      ! 
    394394      CALL iom_put("Courant",Cu_adv) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/DYN/wet_dry.F90

    r12724 r13228  
    242242            ENDIF 
    243243         END_2D 
    244          CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. ) 
     244         CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 
    245245         ! 
    246246         CALL mpp_max('wet_dry', jflag)   !max over the global domain 
    … …  
    258258      ! 
    259259!!gm TO BE SUPPRESSED ?  these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! 
    260       CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm)  , 'U', -1., pvv(:,:,:,Kmm)  , 'V', -1. ) 
    261       CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1., vv_b(:,:,Kmm), 'V', -1. ) 
     260      CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm)  , 'U', -1.0_wp, pvv(:,:,:,Kmm)  , 'V', -1.0_wp ) 
     261      CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) 
    262262!!gm 
    263263      ! 
    … …  
    367367         END_2D 
    368368         ! 
    369          CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. ) 
     369         CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 
    370370         ! 
    371371         CALL mpp_max('wet_dry', jflag)   !max over the global domain 
    … …  
    379379      ! 
    380380!!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop 
    381       CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1., zflxv, 'V', -1. ) 
     381      CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1.0_wp, zflxv, 'V', -1.0_wp ) 
    382382!!gm end 
    383383      ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ICB/icblbc.F90

    r12377 r13228  
    8181      TYPE(iceberg), POINTER ::   this 
    8282      TYPE(point)  , POINTER ::   pt 
    83       INTEGER                ::   iine 
    8483      !!---------------------------------------------------------------------- 
    8584 
    … …  
    9291         DO WHILE( ASSOCIATED(this) ) 
    9392            pt => this%current_point 
    94             iine = INT( pt%xi + 0.5 ) 
    95             IF( iine > mig(nicbei) ) THEN 
     93            IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN 
    9694               pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp 
    97             ELSE IF( iine < mig(nicbdi) ) THEN 
     95            ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN 
    9896               pt%xi = ricb_left + MOD(pt%xi, 1._wp ) 
    9997            ENDIF 
    … …  
    128126         pt => this%current_point 
    129127         ijne = INT( pt%yj + 0.5 ) 
    130          IF( ijne .GT. mjg(nicbej) ) THEN 
     128         IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 
    131129            ! 
    132130            iine = INT( pt%xi + 0.5 ) 
    … …  
    170168      INTEGER                             ::   ibergs_rcvd_from_n, ibergs_rcvd_from_s 
    171169      INTEGER                             ::   i, ibergs_start, ibergs_end 
    172       INTEGER                             ::   iine, ijne 
    173170      INTEGER                             ::   ipe_N, ipe_S, ipe_W, ipe_E 
    174171      REAL(wp), DIMENSION(2)              ::   zewbergs, zwebergs, znsbergs, zsnbergs 
    … …  
    234231         DO WHILE (ASSOCIATED(this)) 
    235232            pt => this%current_point 
    236             iine = INT( pt%xi + 0.5 ) 
    237             IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN 
     233            IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN 
    238234               tmpberg => this 
    239235               this => this%next 
    … …  
    248244               CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) 
    249245               CALL icb_utl_delete(first_berg, tmpberg) 
    250             ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi) ) THEN 
     246            ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN 
    251247               tmpberg => this 
    252248               this => this%next 
    … …  
    372368         DO WHILE (ASSOCIATED(this)) 
    373369            pt => this%current_point 
    374             ijne = INT( pt%yj + 0.5 ) 
    375             IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN 
     370            IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 
    376371               tmpberg => this 
    377372               this => this%next 
    … …  
    383378               CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) 
    384379               CALL icb_utl_delete(first_berg, tmpberg) 
    385             ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj) ) THEN 
     380            ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp ) THEN 
    386381               tmpberg => this 
    387382               this => this%next 
    … …  
    539534         DO WHILE (ASSOCIATED(this)) 
    540535            pt => this%current_point 
    541             iine = INT( pt%xi + 0.5 ) 
    542             ijne = INT( pt%yj + 0.5 ) 
    543             IF( iine .LT. mig(nicbdi) .OR. & 
    544                 iine .GT. mig(nicbei) .OR. & 
    545                 ijne .LT. mjg(nicbdj) .OR. & 
    546                 ijne .GT. mjg(nicbej)) THEN 
     536            IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp .OR. & 
     537                pt%xi > REAL(mig(nicbei),wp) + 0.5_wp .OR. & 
     538                pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp .OR. & 
     539                pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 
    547540               i = i + 1 
    548                WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne 
     541               WRITE(numicb,*) 'berg lost in halo: ', this%number(:) 
    549542               WRITE(numicb,*) '                   ', nimpp, njmpp 
    550543               WRITE(numicb,*) '                   ', nicbdi, nicbei, nicbdj, nicbej 
    … …  
    614607                  pt => this%current_point 
    615608                  iine = INT( pt%xi + 0.5 ) 
    616                   ijne = INT( pt%yj + 0.5 ) 
    617609                  iproc = nicbflddest(mi1(iine)) 
    618                   IF( ijne .GT. mjg(nicbej) ) THEN 
     610                  IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 
    619611                     IF( iproc == ifldproc ) THEN 
    620612                        ! 
    … …  
    696688                  ipts  = nicbfldpts (mi1(iine)) 
    697689                  iproc = nicbflddest(mi1(iine)) 
    698                   IF( ijne .GT. mjg(nicbej) ) THEN 
     690                  IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN 
    699691                     IF( iproc == ifldproc ) THEN 
    700692                        ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ICB/icbthm.F90

    r12291 r13228  
    5757      TYPE(point)  , POINTER ::   pt 
    5858      ! 
    59       COMPLEX(wp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx 
     59      COMPLEX(dp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx 
    6060      !!---------------------------------------------------------------------- 
    6161      ! 
    6262      !! initialiaze cicb_melt and cicb_heat 
    63       cicb_melt = CMPLX( 0.e0, 0.e0, wp )  
    64       cicb_hflx = CMPLX( 0.e0, 0.e0, wp )  
     63      cicb_melt = CMPLX( 0.e0, 0.e0, dp )  
     64      cicb_hflx = CMPLX( 0.e0, 0.e0, dp )  
    6565      ! 
    6666      z1_rday = 1._wp / rday 
    … …  
    176176            !! the use of DDPDD function for the cumulative sum is needed for reproducibility 
    177177            zmelt    = ( zdM - ( zdMbitsE - zdMbitsM ) ) * z1_dt   ! kg/s 
    178             CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, wp ), cicb_melt(ii,ij) ) 
     178            CALL DDPDD( CMPLX( zmelt * z1_e1e2, 0.e0, dp ), cicb_melt(ii,ij) ) 
    179179            ! 
    180180            ! iceberg heat flux 
    … …  
    185185            zheat_hcflux = zmelt * pt%heat_density       ! heat content flux : kg/s x J/kg = J/s 
    186186            zheat_latent = - zmelt * rLfus               ! latent heat flux:  kg/s x J/kg = J/s 
    187             CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, wp ), cicb_hflx(ii,ij) ) 
     187            CALL DDPDD( CMPLX( ( zheat_hcflux + zheat_latent ) * z1_e1e2, 0.e0, dp ), cicb_hflx(ii,ij) ) 
    188188            ! 
    189189            ! diagnostics 
    … …  
    230230      END DO 
    231231      ! 
    232       berg_grid%floating_melt = REAL(cicb_melt,wp)    ! kg/m2/s 
    233       berg_grid%calving_hflx  = REAL(cicb_hflx,wp) 
     232      berg_grid%floating_melt = REAL(cicb_melt,dp)    ! kg/m2/s 
     233      berg_grid%calving_hflx  = REAL(cicb_hflx,dp) 
    234234      ! 
    235235      ! now use melt and associated heat flux in ocean (or not) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/IOM/iom.F90

    r13217 r13228  
    5959   PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 
    6060 
    61    PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 
    62    PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d 
    63    PRIVATE iom_p1d, iom_p2d, iom_p3d, iom_p4d 
     61   PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 
     62   PRIVATE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 
     63   PRIVATE iom_get_123d 
     64   PRIVATE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 
     65   PRIVATE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 
     66   PRIVATE iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 
     67   PRIVATE iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 
    6468#if defined key_iomput 
    6569   PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 
    … …  
    7074 
    7175   INTERFACE iom_get 
    72       MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d 
     76      MODULE PROCEDURE iom_g0d_sp, iom_g1d_sp, iom_g2d_sp, iom_g3d_sp 
     77      MODULE PROCEDURE iom_g0d_dp, iom_g1d_dp, iom_g2d_dp, iom_g3d_dp 
    7378   END INTERFACE 
    7479   INTERFACE iom_getatt 
    … …  
    7984   END INTERFACE 
    8085   INTERFACE iom_rstput 
    81       MODULE PROCEDURE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 
     86      MODULE PROCEDURE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 
     87      MODULE PROCEDURE iom_rp0d_dp, iom_rp1d_dp, iom_rp2d_dp, iom_rp3d_dp 
    8288   END INTERFACE 
    8389   INTERFACE iom_put 
    84       MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d, iom_p4d 
     90      MODULE PROCEDURE iom_p0d_sp, iom_p1d_sp, iom_p2d_sp, iom_p3d_sp, iom_p4d_sp 
     91      MODULE PROCEDURE iom_p0d_dp, iom_p1d_dp, iom_p2d_dp, iom_p3d_dp, iom_p4d_dp 
    8592   END INTERFACE iom_put 
    8693   
    … …  
    169176         ! 
    170177         IF( ln_cfmeta ) THEN   ! Add additional grid metadata 
    171             CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej)) 
    172             CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej)) 
    173             CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej)) 
    174             CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej)) 
     178            CALL iom_set_domain_attr("grid_T", area = real( e1e2t(nldi:nlei, nldj:nlej), dp)) 
     179            CALL iom_set_domain_attr("grid_U", area = real( e1e2u(nldi:nlei, nldj:nlej), dp)) 
     180            CALL iom_set_domain_attr("grid_V", area = real( e1e2v(nldi:nlei, nldj:nlej), dp)) 
     181            CALL iom_set_domain_attr("grid_W", area = real( e1e2t(nldi:nlei, nldj:nlej), dp)) 
    175182            CALL set_grid_bounds( "T", glamf, gphif, glamt, gphit ) 
    176183            CALL set_grid_bounds( "U", glamv, gphiv, glamu, gphiu ) 
    … …  
    192199         ! 
    193200         IF( ln_cfmeta .AND. .NOT. llrst_context) THEN   ! Add additional grid metadata 
    194             CALL iom_set_domain_attr("grid_T", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 
    195             CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej)) 
    196             CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej)) 
    197             CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej)) 
     201            CALL iom_set_domain_attr("grid_T", area = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp)) 
     202            CALL iom_set_domain_attr("grid_U", area = real(e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej), dp) ) 
     203            CALL iom_set_domain_attr("grid_V", area = real(e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej), dp) ) 
     204            CALL iom_set_domain_attr("grid_W", area = real(e1e2t_crs(nldi:nlei, nldj:nlej), dp ) ) 
    198205            CALL set_grid_bounds( "T", glamf_crs, gphif_crs, glamt_crs, gphit_crs ) 
    199206            CALL set_grid_bounds( "U", glamv_crs, gphiv_crs, glamu_crs, gphiu_crs ) 
    … …  
    941948   !!                   INTERFACE iom_get 
    942949   !!---------------------------------------------------------------------- 
    943    SUBROUTINE iom_g0d( kiomid, cdvar, pvar, ktime, ldxios ) 
     950   SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 
    944951      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file 
    945952      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable 
    946       REAL(wp)        , INTENT(  out)                 ::   pvar      ! read field 
     953      REAL(sp)        , INTENT(  out)                 ::   pvar      ! read field 
     954      REAL(dp)                                        ::   ztmp_pvar ! tmp var to read field 
     955      INTEGER         , INTENT(in   ),     OPTIONAL   ::   ktime     ! record number 
     956      LOGICAL         , INTENT(in   ),     OPTIONAL   ::   ldxios    ! use xios to read restart 
     957      ! 
     958      INTEGER                                         ::   idvar     ! variable id 
     959      INTEGER                                         ::   idmspc    ! number of spatial dimensions 
     960      INTEGER         , DIMENSION(1)                  ::   itime     ! record number 
     961      CHARACTER(LEN=100)                              ::   clinfo    ! info character 
     962      CHARACTER(LEN=100)                              ::   clname    ! file name 
     963      CHARACTER(LEN=1)                                ::   cldmspc   ! 
     964      LOGICAL                                         ::   llxios 
     965      ! 
     966      llxios = .FALSE. 
     967      IF( PRESENT(ldxios) ) llxios = ldxios 
     968 
     969      IF(.NOT.llxios) THEN  ! read data using default library 
     970         itime = 1 
     971         IF( PRESENT(ktime) ) itime = ktime 
     972         ! 
     973         clname = iom_file(kiomid)%name 
     974         clinfo = '          iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) 
     975         ! 
     976         IF( kiomid > 0 ) THEN 
     977            idvar = iom_varid( kiomid, cdvar ) 
     978            IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN 
     979               idmspc = iom_file ( kiomid )%ndims( idvar ) 
     980               IF( iom_file(kiomid)%luld(idvar) )  idmspc = idmspc - 1 
     981               WRITE(cldmspc , fmt='(i1)') idmspc 
     982               IF( idmspc > 0 )  CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & 
     983                                    &                         'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & 
     984                                    &                         'Use ncwa -a to suppress the unnecessary dimensions' ) 
     985               CALL iom_nf90_get( kiomid, idvar, ztmp_pvar, itime ) 
     986               pvar = ztmp_pvar 
     987            ENDIF 
     988         ENDIF 
     989      ELSE 
     990#if defined key_iomput 
     991         IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 
     992         CALL iom_swap( TRIM(crxios_context) ) 
     993         CALL xios_recv_field( trim(cdvar), pvar) 
     994         CALL iom_swap( TRIM(cxios_context) ) 
     995#else 
     996         WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 
     997         CALL ctl_stop( 'iom_g0d', ctmp1 ) 
     998#endif 
     999      ENDIF 
     1000   END SUBROUTINE iom_g0d_sp 
     1001 
     1002   SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 
     1003      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file 
     1004      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable 
     1005      REAL(dp)        , INTENT(  out)                 ::   pvar      ! read field 
    9471006      INTEGER         , INTENT(in   ),     OPTIONAL   ::   ktime     ! record number 
    9481007      LOGICAL         , INTENT(in   ),     OPTIONAL   ::   ldxios    ! use xios to read restart 
    … …  
    9891048#endif 
    9901049      ENDIF 
    991    END SUBROUTINE iom_g0d 
    992  
    993    SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 
     1050   END SUBROUTINE iom_g0d_dp 
     1051 
     1052   SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 
    9941053      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    9951054      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    9961055      CHARACTER(len=*), INTENT(in   )                         ::   cdvar     ! Name of the variable 
    997       REAL(wp)        , INTENT(  out), DIMENSION(:)           ::   pvar      ! read field 
     1056      REAL(sp)        , INTENT(  out), DIMENSION(:)           ::   pvar      ! read field 
     1057      REAL(dp)        , ALLOCATABLE  , DIMENSION(:)           ::   ztmp_pvar ! tmp var to read field 
    9981058      INTEGER         , INTENT(in   )              , OPTIONAL ::   ktime     ! record number 
    9991059      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading  
    … …  
    10021062      ! 
    10031063      IF( kiomid > 0 ) THEN 
     1064         IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1065            ALLOCATE(ztmp_pvar(size(pvar,1))) 
     1066            CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r1d=ztmp_pvar,   & 
     1067              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     1068              &                                                     ldxios=ldxios ) 
     1069            pvar = ztmp_pvar 
     1070            DEALLOCATE(ztmp_pvar) 
     1071         END IF 
     1072      ENDIF 
     1073   END SUBROUTINE iom_g1d_sp 
     1074 
     1075 
     1076   SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 
     1077      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
     1078      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
     1079      CHARACTER(len=*), INTENT(in   )                         ::   cdvar     ! Name of the variable 
     1080      REAL(dp)        , INTENT(  out), DIMENSION(:)           ::   pvar      ! read field 
     1081      INTEGER         , INTENT(in   )              , OPTIONAL ::   ktime     ! record number 
     1082      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading  
     1083      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kcount    ! number of points in each axis 
     1084      LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
     1085      ! 
     1086      IF( kiomid > 0 ) THEN 
    10041087         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r1d=pvar,   & 
    10051088              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
    10061089              &                                                     ldxios=ldxios ) 
    10071090      ENDIF 
    1008    END SUBROUTINE iom_g1d 
    1009  
    1010    SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 
     1091   END SUBROUTINE iom_g1d_dp 
     1092 
     1093   SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 
    10111094      INTEGER         , INTENT(in   )                           ::   kiomid    ! Identifier of the file 
    10121095      INTEGER         , INTENT(in   )                           ::   kdom      ! Type of domain to be read 
    10131096      CHARACTER(len=*), INTENT(in   )                           ::   cdvar     ! Name of the variable 
    1014       REAL(wp)        , INTENT(  out), DIMENSION(:,:)           ::   pvar      ! read field 
     1097      REAL(sp)        , INTENT(  out), DIMENSION(:,:)           ::   pvar      ! read field 
     1098      REAL(dp)        , ALLOCATABLE  , DIMENSION(:,:)           ::   ztmp_pvar ! tmp var to read field 
    10151099      INTEGER         , INTENT(in   )                , OPTIONAL ::   ktime     ! record number 
    10161100      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kstart    ! start axis position of the reading  
    … …  
    10231107      ! 
    10241108      IF( kiomid > 0 ) THEN 
     1109         IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1110            ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2))) 
     1111            CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r2d=ztmp_pvar,   & 
     1112              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     1113              &                                                     lrowattr=lrowattr,  ldxios=ldxios) 
     1114            pvar = ztmp_pvar 
     1115            DEALLOCATE(ztmp_pvar) 
     1116         END IF 
     1117      ENDIF 
     1118   END SUBROUTINE iom_g2d_sp 
     1119 
     1120 
     1121   SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) 
     1122      INTEGER         , INTENT(in   )                           ::   kiomid    ! Identifier of the file 
     1123      INTEGER         , INTENT(in   )                           ::   kdom      ! Type of domain to be read 
     1124      CHARACTER(len=*), INTENT(in   )                           ::   cdvar     ! Name of the variable 
     1125      REAL(dp)        , INTENT(  out), DIMENSION(:,:)           ::   pvar      ! read field 
     1126      INTEGER         , INTENT(in   )                , OPTIONAL ::   ktime     ! record number 
     1127      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kstart    ! start axis position of the reading  
     1128      INTEGER         , INTENT(in   ), DIMENSION(2)  , OPTIONAL ::   kcount    ! number of points in each axis 
     1129      LOGICAL         , INTENT(in   )                , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to 
     1130                                                                               ! look for and use a file attribute 
     1131                                                                               ! called open_ocean_jstart to set the start 
     1132                                                                               ! value for the 2nd dimension (netcdf only) 
     1133      LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios      ! read data using XIOS 
     1134      ! 
     1135      IF( kiomid > 0 ) THEN 
    10251136         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r2d=pvar,   & 
    10261137              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
    10271138              &                                                     lrowattr=lrowattr,  ldxios=ldxios) 
    10281139      ENDIF 
    1029    END SUBROUTINE iom_g2d 
    1030  
    1031    SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 
     1140   END SUBROUTINE iom_g2d_dp 
     1141 
     1142   SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 
    10321143      INTEGER         , INTENT(in   )                             ::   kiomid    ! Identifier of the file 
    10331144      INTEGER         , INTENT(in   )                             ::   kdom      ! Type of domain to be read 
    10341145      CHARACTER(len=*), INTENT(in   )                             ::   cdvar     ! Name of the variable 
    1035       REAL(wp)        , INTENT(  out), DIMENSION(:,:,:)           ::   pvar      ! read field 
     1146      REAL(sp)        , INTENT(  out), DIMENSION(:,:,:)           ::   pvar      ! read field 
     1147      REAL(dp)        , ALLOCATABLE  , DIMENSION(:,:,:)           ::   ztmp_pvar ! tmp var to read field 
    10361148      INTEGER         , INTENT(in   )                  , OPTIONAL ::   ktime     ! record number 
    10371149      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kstart    ! start axis position of the reading  
    … …  
    10441156      ! 
    10451157      IF( kiomid > 0 ) THEN 
     1158         IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1159            ALLOCATE(ztmp_pvar(size(pvar,1), size(pvar,2), size(pvar,3))) 
     1160            CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r3d=ztmp_pvar,   & 
     1161              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
     1162              &                                                     lrowattr=lrowattr, ldxios=ldxios ) 
     1163            pvar = ztmp_pvar 
     1164            DEALLOCATE(ztmp_pvar) 
     1165         END IF 
     1166      ENDIF 
     1167   END SUBROUTINE iom_g3d_sp 
     1168 
     1169   SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) 
     1170      INTEGER         , INTENT(in   )                             ::   kiomid    ! Identifier of the file 
     1171      INTEGER         , INTENT(in   )                             ::   kdom      ! Type of domain to be read 
     1172      CHARACTER(len=*), INTENT(in   )                             ::   cdvar     ! Name of the variable 
     1173      REAL(dp)        , INTENT(  out), DIMENSION(:,:,:)           ::   pvar      ! read field 
     1174      INTEGER         , INTENT(in   )                  , OPTIONAL ::   ktime     ! record number 
     1175      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kstart    ! start axis position of the reading  
     1176      INTEGER         , INTENT(in   ), DIMENSION(3)    , OPTIONAL ::   kcount    ! number of points in each axis 
     1177      LOGICAL         , INTENT(in   )                  , OPTIONAL ::   lrowattr  ! logical flag telling iom_get to 
     1178                                                                                 ! look for and use a file attribute 
     1179                                                                                 ! called open_ocean_jstart to set the start 
     1180                                                                                 ! value for the 2nd dimension (netcdf only) 
     1181      LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios        ! read data using XIOS 
     1182      ! 
     1183      IF( kiomid > 0 ) THEN 
    10461184         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r3d=pvar,   & 
    10471185              &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
    10481186              &                                                     lrowattr=lrowattr, ldxios=ldxios ) 
    10491187      ENDIF 
    1050    END SUBROUTINE iom_g3d 
     1188   END SUBROUTINE iom_g3d_dp 
     1189 
     1190 
     1191 
    10511192   !!---------------------------------------------------------------------- 
    10521193 
    … …  
    10651206      INTEGER                    , INTENT(in   )           ::   kdom       ! Type of domain to be read 
    10661207      CHARACTER(len=*)           , INTENT(in   )           ::   cdvar      ! Name of the variable 
    1067       REAL(wp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d     ! read field (1D case) 
    1068       REAL(wp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d     ! read field (2D case) 
    1069       REAL(wp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d     ! read field (3D case) 
     1208      REAL(dp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d     ! read field (1D case) 
     1209      REAL(dp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d     ! read field (2D case) 
     1210      REAL(dp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d     ! read field (3D case) 
    10701211      INTEGER                    , INTENT(in   ), OPTIONAL ::   ktime      ! record number 
    10711212      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart     ! start position of the reading in each axis  
    … …  
    10961237      INTEGER, DIMENSION(jpmax_dims) ::   idimsz      ! size of the dimensions of the variable 
    10971238      INTEGER, DIMENSION(jpmax_dims) ::   ishape      ! size of the dimensions of the variable 
    1098       REAL(wp)                       ::   zscf, zofs  ! sacle_factor and add_offset 
     1239      REAL(dp)                       ::   zscf, zofs  ! sacle_factor and add_offset 
    10991240      INTEGER                        ::   itmp        ! temporary integer 
    11001241      CHARACTER(LEN=256)             ::   clinfo      ! info character 
    … …  
    11031244      LOGICAL                        ::   ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 
    11041245      INTEGER                        ::   inlev       ! number of levels for 3D data 
    1105       REAL(wp)                       ::   gma, gmi 
     1246      REAL(dp)                       ::   gma, gmi 
    11061247      !--------------------------------------------------------------------- 
    11071248      ! 
    … …  
    13121453               !--- overlap areas and extra hallows (mpp) 
    13131454               IF(     PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 
    1314                   CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing ) 
     1455                  CALL lbc_lnk( 'iom', pv_r2d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 
    13151456               ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 
    13161457                  ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 
    13171458                  IF( icnt(3) == inlev ) THEN 
    1318                      CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing ) 
     1459                     CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing ) 
    13191460                  ELSE   ! put some arbitrary value (a call to lbc_lnk will be done later...) 
    13201461                     DO jj = nlcj+1, jpj   ;   pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :)   ;   END DO 
    … …  
    13411482            CALL xios_recv_field( trim(cdvar), pv_r3d) 
    13421483            IF(idom /= jpdom_unknown ) then 
    1343                 CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 
     1484                CALL lbc_lnk( 'iom', pv_r3d,'Z', -999.0_wp, kfillmode = jpfillnothing) 
    13441485            ENDIF 
    13451486         ELSEIF( PRESENT(pv_r2d) ) THEN 
    … …  
    13481489            CALL xios_recv_field( trim(cdvar), pv_r2d) 
    13491490            IF(idom /= jpdom_unknown ) THEN 
    1350                 CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 
     1491                CALL lbc_lnk('iom', pv_r2d,'Z',-999.0_wp, kfillmode = jpfillnothing) 
    13511492            ENDIF 
    13521493         ELSEIF( PRESENT(pv_r1d) ) THEN 
    … …  
    13631504!some final adjustments 
    13641505      ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain 
    1365       IF( lk_c1d .AND. PRESENT(pv_r2d) )   CALL lbc_lnk( 'iom', pv_r2d,'Z',1. ) 
    1366       IF( lk_c1d .AND. PRESENT(pv_r3d) )   CALL lbc_lnk( 'iom', pv_r3d,'Z',1. ) 
     1506      IF( lk_c1d .AND. PRESENT(pv_r2d) )   CALL lbc_lnk( 'iom', pv_r2d,'Z',1.0_wp ) 
     1507      IF( lk_c1d .AND. PRESENT(pv_r3d) )   CALL lbc_lnk( 'iom', pv_r3d,'Z',1.0_wp ) 
    13671508 
    13681509      !--- Apply scale_factor and offset 
    … …  
    15511692   !!                   INTERFACE iom_rstput 
    15521693   !!---------------------------------------------------------------------- 
    1553    SUBROUTINE iom_rp0d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1694   SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    15541695      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    15551696      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    15561697      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    15571698      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1558       REAL(wp)        , INTENT(in)                         ::   pvar     ! written field 
     1699      REAL(sp)        , INTENT(in)                         ::   pvar     ! written field 
    15591700      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    15601701      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    … …  
    15751716            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    15761717               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    1577                CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 
     1718               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) 
    15781719            ENDIF 
    15791720         ENDIF 
    15801721      ENDIF 
    1581    END SUBROUTINE iom_rp0d 
    1582  
    1583    SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1722   END SUBROUTINE iom_rp0d_sp 
     1723 
     1724   SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    15841725      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    15851726      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    15861727      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    15871728      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1588       REAL(wp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
     1729      REAL(dp)        , INTENT(in)                         ::   pvar     ! written field 
     1730      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1731      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
     1732      LOGICAL :: llx                ! local xios write flag 
     1733      INTEGER :: ivid   ! variable id 
     1734 
     1735      llx = .FALSE. 
     1736      IF(PRESENT(ldxios)) llx = ldxios 
     1737      IF( llx ) THEN 
     1738#ifdef key_iomput 
     1739      IF( kt == kwrite ) THEN 
     1740          IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 
     1741          CALL xios_send_field(trim(cdvar), pvar) 
     1742      ENDIF 
     1743#endif 
     1744      ELSE 
     1745         IF( kiomid > 0 ) THEN 
     1746            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1747               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1748               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 
     1749            ENDIF 
     1750         ENDIF 
     1751      ENDIF 
     1752   END SUBROUTINE iom_rp0d_dp 
     1753 
     1754 
     1755   SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1756      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1757      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1758      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1759      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1760      REAL(sp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
    15891761      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    15901762      LOGICAL, OPTIONAL                                    ::   ldxios   ! xios write flag 
    … …  
    16051777            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    16061778               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    1607                CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 
     1779               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) 
    16081780            ENDIF 
    16091781         ENDIF 
    16101782      ENDIF 
    1611    END SUBROUTINE iom_rp1d 
    1612  
    1613    SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1783   END SUBROUTINE iom_rp1d_sp 
     1784 
     1785   SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    16141786      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16151787      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    16161788      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    16171789      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1618       REAL(wp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
     1790      REAL(dp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
     1791      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1792      LOGICAL, OPTIONAL                                    ::   ldxios   ! xios write flag 
     1793      LOGICAL :: llx                ! local xios write flag 
     1794      INTEGER :: ivid   ! variable id 
     1795 
     1796      llx = .FALSE. 
     1797      IF(PRESENT(ldxios)) llx = ldxios 
     1798      IF( llx ) THEN 
     1799#ifdef key_iomput 
     1800      IF( kt == kwrite ) THEN 
     1801         IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 
     1802         CALL xios_send_field(trim(cdvar), pvar) 
     1803      ENDIF 
     1804#endif 
     1805      ELSE 
     1806         IF( kiomid > 0 ) THEN 
     1807            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1808               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1809               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 
     1810            ENDIF 
     1811         ENDIF 
     1812      ENDIF 
     1813   END SUBROUTINE iom_rp1d_dp 
     1814 
     1815 
     1816   SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1817      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1818      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1819      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1820      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1821      REAL(sp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
    16191822      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    16201823      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    … …  
    16351838            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    16361839               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    1637                CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 
     1840               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) 
    16381841            ENDIF 
    16391842         ENDIF 
    16401843      ENDIF 
    1641    END SUBROUTINE iom_rp2d 
    1642  
    1643    SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1844   END SUBROUTINE iom_rp2d_sp 
     1845 
     1846   SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    16441847      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16451848      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    16461849      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    16471850      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1648       REAL(wp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
     1851      REAL(dp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
     1852      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1853      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
     1854      LOGICAL :: llx 
     1855      INTEGER :: ivid   ! variable id 
     1856 
     1857      llx = .FALSE. 
     1858      IF(PRESENT(ldxios)) llx = ldxios 
     1859      IF( llx ) THEN 
     1860#ifdef key_iomput 
     1861      IF( kt == kwrite ) THEN 
     1862         IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 
     1863         CALL xios_send_field(trim(cdvar), pvar) 
     1864      ENDIF 
     1865#endif 
     1866      ELSE 
     1867         IF( kiomid > 0 ) THEN 
     1868            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1869               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1870               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 
     1871            ENDIF 
     1872         ENDIF 
     1873      ENDIF 
     1874   END SUBROUTINE iom_rp2d_dp 
     1875 
     1876 
     1877   SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1878      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1879      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1880      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1881      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1882      REAL(sp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
    16491883      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    16501884      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    … …  
    16651899            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    16661900               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1901               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) 
     1902            ENDIF 
     1903         ENDIF 
     1904      ENDIF 
     1905   END SUBROUTINE iom_rp3d_sp 
     1906 
     1907   SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1908      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1909      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1910      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1911      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1912      REAL(dp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
     1913      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1914      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
     1915      LOGICAL :: llx                 ! local xios write flag 
     1916      INTEGER :: ivid   ! variable id 
     1917 
     1918      llx = .FALSE. 
     1919      IF(PRESENT(ldxios)) llx = ldxios 
     1920      IF( llx ) THEN 
     1921#ifdef key_iomput 
     1922      IF( kt == kwrite ) THEN 
     1923         IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 
     1924         CALL xios_send_field(trim(cdvar), pvar) 
     1925      ENDIF 
     1926#endif 
     1927      ELSE 
     1928         IF( kiomid > 0 ) THEN 
     1929            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1930               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    16671931               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) 
    16681932            ENDIF 
    16691933         ENDIF 
    16701934      ENDIF 
    1671    END SUBROUTINE iom_rp3d 
     1935   END SUBROUTINE iom_rp3d_dp 
     1936 
    16721937 
    16731938 
    … …  
    17211986   !!                   INTERFACE iom_put 
    17221987   !!---------------------------------------------------------------------- 
    1723    SUBROUTINE iom_p0d( cdname, pfield0d ) 
     1988   SUBROUTINE iom_p0d_sp( cdname, pfield0d ) 
    17241989      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    1725       REAL(wp)        , INTENT(in) ::   pfield0d 
     1990      REAL(sp)        , INTENT(in) ::   pfield0d 
    17261991!!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    17271992#if defined key_iomput 
    … …  
    17321997      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
    17331998#endif 
    1734    END SUBROUTINE iom_p0d 
    1735  
    1736    SUBROUTINE iom_p1d( cdname, pfield1d ) 
     1999   END SUBROUTINE iom_p0d_sp 
     2000 
     2001   SUBROUTINE iom_p0d_dp( cdname, pfield0d ) 
     2002      CHARACTER(LEN=*), INTENT(in) ::   cdname 
     2003      REAL(dp)        , INTENT(in) ::   pfield0d 
     2004!!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     2005#if defined key_iomput 
     2006!!clem      zz(:,:)=pfield0d 
     2007!!clem      CALL xios_send_field(cdname, zz) 
     2008      CALL xios_send_field(cdname, (/pfield0d/))  
     2009#else 
     2010      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
     2011#endif 
     2012   END SUBROUTINE iom_p0d_dp 
     2013 
     2014 
     2015   SUBROUTINE iom_p1d_sp( cdname, pfield1d ) 
    17372016      CHARACTER(LEN=*)          , INTENT(in) ::   cdname 
    1738       REAL(wp),     DIMENSION(:), INTENT(in) ::   pfield1d 
     2017      REAL(sp),     DIMENSION(:), INTENT(in) ::   pfield1d 
    17392018#if defined key_iomput 
    17402019      CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 
    … …  
    17422021      IF( .FALSE. )   WRITE(numout,*) cdname, pfield1d   ! useless test to avoid compilation warnings 
    17432022#endif 
    1744    END SUBROUTINE iom_p1d 
    1745  
    1746    SUBROUTINE iom_p2d( cdname, pfield2d ) 
     2023   END SUBROUTINE iom_p1d_sp 
     2024 
     2025   SUBROUTINE iom_p1d_dp( cdname, pfield1d ) 
     2026      CHARACTER(LEN=*)          , INTENT(in) ::   cdname 
     2027      REAL(dp),     DIMENSION(:), INTENT(in) ::   pfield1d 
     2028#if defined key_iomput 
     2029      CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 
     2030#else 
     2031      IF( .FALSE. )   WRITE(numout,*) cdname, pfield1d   ! useless test to avoid compilation warnings 
     2032#endif 
     2033   END SUBROUTINE iom_p1d_dp 
     2034 
     2035   SUBROUTINE iom_p2d_sp( cdname, pfield2d ) 
    17472036      CHARACTER(LEN=*)            , INTENT(in) ::   cdname 
    1748       REAL(wp),     DIMENSION(:,:), INTENT(in) ::   pfield2d 
     2037      REAL(sp),     DIMENSION(:,:), INTENT(in) ::   pfield2d 
    17492038#if defined key_iomput 
    17502039      CALL xios_send_field(cdname, pfield2d) 
    … …  
    17522041      IF( .FALSE. )   WRITE(numout,*) cdname, pfield2d   ! useless test to avoid compilation warnings 
    17532042#endif 
    1754    END SUBROUTINE iom_p2d 
    1755  
    1756    SUBROUTINE iom_p3d( cdname, pfield3d ) 
     2043   END SUBROUTINE iom_p2d_sp 
     2044 
     2045   SUBROUTINE iom_p2d_dp( cdname, pfield2d ) 
     2046      CHARACTER(LEN=*)            , INTENT(in) ::   cdname 
     2047      REAL(dp),     DIMENSION(:,:), INTENT(in) ::   pfield2d 
     2048#if defined key_iomput 
     2049      CALL xios_send_field(cdname, pfield2d) 
     2050#else 
     2051      IF( .FALSE. )   WRITE(numout,*) cdname, pfield2d   ! useless test to avoid compilation warnings 
     2052#endif 
     2053   END SUBROUTINE iom_p2d_dp 
     2054 
     2055   SUBROUTINE iom_p3d_sp( cdname, pfield3d ) 
    17572056      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
    1758       REAL(wp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d 
     2057      REAL(sp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d 
    17592058#if defined key_iomput 
    17602059      CALL xios_send_field( cdname, pfield3d ) 
    … …  
    17622061      IF( .FALSE. )   WRITE(numout,*) cdname, pfield3d   ! useless test to avoid compilation warnings 
    17632062#endif 
    1764    END SUBROUTINE iom_p3d 
    1765  
    1766    SUBROUTINE iom_p4d( cdname, pfield4d ) 
     2063   END SUBROUTINE iom_p3d_sp 
     2064 
     2065   SUBROUTINE iom_p3d_dp( cdname, pfield3d ) 
    17672066      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
    1768       REAL(wp),       DIMENSION(:,:,:,:), INTENT(in) ::   pfield4d 
     2067      REAL(dp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d 
     2068#if defined key_iomput 
     2069      CALL xios_send_field( cdname, pfield3d ) 
     2070#else 
     2071      IF( .FALSE. )   WRITE(numout,*) cdname, pfield3d   ! useless test to avoid compilation warnings 
     2072#endif 
     2073   END SUBROUTINE iom_p3d_dp 
     2074 
     2075   SUBROUTINE iom_p4d_sp( cdname, pfield4d ) 
     2076      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
     2077      REAL(sp),       DIMENSION(:,:,:,:), INTENT(in) ::   pfield4d 
    17692078#if defined key_iomput 
    17702079      CALL xios_send_field(cdname, pfield4d) 
    … …  
    17722081      IF( .FALSE. )   WRITE(numout,*) cdname, pfield4d   ! useless test to avoid compilation warnings 
    17732082#endif 
    1774    END SUBROUTINE iom_p4d 
    1775  
     2083   END SUBROUTINE iom_p4d_sp 
     2084 
     2085   SUBROUTINE iom_p4d_dp( cdname, pfield4d ) 
     2086      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
     2087      REAL(dp),       DIMENSION(:,:,:,:), INTENT(in) ::   pfield4d 
     2088#if defined key_iomput 
     2089      CALL xios_send_field(cdname, pfield4d) 
     2090#else 
     2091      IF( .FALSE. )   WRITE(numout,*) cdname, pfield4d   ! useless test to avoid compilation warnings 
     2092#endif 
     2093   END SUBROUTINE iom_p4d_dp 
    17762094 
    17772095#if defined key_iomput 
    … …  
    17892107      INTEGER                 , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj 
    17902108      INTEGER                 , OPTIONAL, INTENT(in) ::   nvertex 
    1791       REAL(wp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    1792       REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
     2109      REAL(dp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
     2110      REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
    17932111      LOGICAL , DIMENSION(:)  , OPTIONAL, INTENT(in) ::   mask 
    17942112      !!---------------------------------------------------------------------- 
    … …  
    18532171      !!---------------------------------------------------------------------- 
    18542172      IF( PRESENT(paxis) ) THEN 
    1855          IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis ) 
    1856          IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 
    1857       ENDIF 
    1858       IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
    1859       IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 
     2173         IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 
     2174         IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 
     2175      ENDIF 
     2176      IF( PRESENT(bounds) ) THEN 
     2177         IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=real(bounds, dp) ) 
     2178         IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) 
     2179      ELSE 
     2180         IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid) 
     2181         IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid) 
     2182      END IF 
    18602183      CALL xios_solve_inheritance() 
    18612184   END SUBROUTINE iom_set_axis_attr 
    … …  
    19762299!don't define lon and lat for restart reading context.  
    19772300      IF ( .NOT.ldrxios ) & 
    1978          CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   & 
    1979          &                                     latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     2301         CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), dp),   & 
     2302         &                                     latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp ) )   
    19802303      ! 
    19812304      IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN 
    … …  
    19832306         SELECT CASE ( cdgrd ) 
    19842307         CASE('T')   ;   zmask(:,:,:)       = tmask(:,:,:) 
    1985          CASE('U')   ;   zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:)   ;   CALL lbc_lnk( 'iom', zmask, 'U', 1. ) 
    1986          CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:)   ;   CALL lbc_lnk( 'iom', zmask, 'V', 1. ) 
     2308         CASE('U')   ;   zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:)   ;   CALL lbc_lnk( 'iom', zmask, 'U', 1.0_wp ) 
     2309         CASE('V')   ;   zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:)   ;   CALL lbc_lnk( 'iom', zmask, 'V', 1.0_wp ) 
    19872310         CASE('W')   ;   zmask(:,:,2:jpk  ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk)   ;   zmask(:,:,1) = tmask(:,:,1) 
    19882311         END SELECT 
    … …  
    20272350      ! 
    20282351      z_fld(:,:) = 1._wp 
    2029       CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. )    ! Working array for location of northfold 
     2352      CALL lbc_lnk( 'iom', z_fld, cdgrd, -1.0_wp )    ! Working array for location of northfold 
    20302353      ! 
    20312354      ! Cell vertices that can be defined 
    … …  
    20452368      ! Cell vertices on boundries 
    20462369      DO jn = 1, 4 
    2047          CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pfillval=999._wp ) 
    2048          CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pfillval=999._wp ) 
     2370         CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1.0_wp, pfillval=999._wp ) 
     2371         CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1.0_wp, pfillval=999._wp ) 
    20492372      END DO 
    20502373      ! 
    … …  
    20922415      ENDIF 
    20932416      ! 
    2094       CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)),           & 
    2095           &                                    bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 
     2417      CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), dp),           & 
     2418          &                                    bounds_lon =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), dp), nvertex=4 ) 
    20962419      ! 
    20972420      DEALLOCATE( z_bnds, z_fld, z_rot )  
    … …  
    21172440      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0._wp 
    21182441      ! 
    2119 !      CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) !  i-line that passes through Bering Strait: Reference latitude (used in plots) 
    2120       CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
     2442!      CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) !  i-line that passes through Bering Strait: Reference latitude (used in plots) 
     2443      CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    21212444      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
    21222445      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    2123       CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
    2124          &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     2446      CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp),   & 
     2447         &                             latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp))   
    21252448      CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 
    21262449      ! 
    … …  
    21372460      !! 
    21382461      !!---------------------------------------------------------------------- 
    2139       REAL(wp), DIMENSION(1)   ::   zz = 1. 
     2462      REAL(dp), DIMENSION(1)   ::   zz = 1. 
    21402463      !!---------------------------------------------------------------------- 
    21412464      ! 
    … …  
    21992522         cl1 = clgrd(jg) 
    22002523         ! Equatorial section (attributs: jbegin, ni, name_suffix) 
    2201          CALL dom_ngb( 0., 0., ix, iy, cl1 ) 
     2524         CALL dom_ngb( 0.0_wp, 0.0_wp, ix, iy, cl1 ) 
    22022525         CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=jpiglo, nj=1 ) 
    22032526         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             ) 
    … …  
    24252748      ! 
    24262749      IF ( ll24 .AND. isec == 0 ) THEN   ! 00:00 of the next day -> move to 24:00 of the current day 
    2427          CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec ) 
     2750         CALL ju2ymds( pjday - 1.0_wp, iyear, imonth, iday, zsec ) 
    24282751         isec = 86400 
    24292752      ENDIF 
    … …  
    24832806      CHARACTER(LEN=*), INTENT(in ) ::   cdname 
    24842807      REAL(wp)        , INTENT(out) ::   pmiss_val    
     2808      REAL(dp)                      ::   ztmp_pmiss_val    
    24852809#if defined key_iomput 
    24862810      ! get missing value 
    2487       CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 
     2811      CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) 
     2812      pmiss_val = ztmp_pmiss_val 
    24882813#else 
    24892814      IF( .FALSE. )   WRITE(numout,*) cdname, pmiss_val   ! useless test to avoid compilation warnings 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/IOM/iom_nf90.F90

    r13193 r13228  
    3333 
    3434   INTERFACE iom_nf90_get 
    35       MODULE PROCEDURE iom_nf90_g0d, iom_nf90_g123d 
     35      MODULE PROCEDURE iom_nf90_g0d_sp                    
     36      MODULE PROCEDURE iom_nf90_g0d_dp, iom_nf90_g123d_dp 
    3637   END INTERFACE 
    3738   INTERFACE iom_nf90_rstput 
    38       MODULE PROCEDURE iom_nf90_rp0123d 
     39      MODULE PROCEDURE iom_nf90_rp0123d_dp 
    3940   END INTERFACE 
    4041 
    … …  
    276277   !!---------------------------------------------------------------------- 
    277278 
    278    SUBROUTINE iom_nf90_g0d( kiomid, kvid, pvar, kstart ) 
     279   SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) 
    279280      !!----------------------------------------------------------------------- 
    280281      !!                  ***  ROUTINE  iom_nf90_g0d  *** 
    … …  
    284285      INTEGER ,               INTENT(in   )            ::   kiomid   ! Identifier of the file 
    285286      INTEGER ,               INTENT(in   )            ::   kvid     ! variable id 
    286       REAL(wp),               INTENT(  out)            ::   pvar     ! read field 
     287      REAL(sp),               INTENT(  out)            ::   pvar     ! read field 
    287288      INTEGER , DIMENSION(1), INTENT(in   ), OPTIONAL  ::   kstart   ! start position of the reading in each axis 
    288289      ! 
    … …  
    291292      clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 
    292293      CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 
    293    END SUBROUTINE iom_nf90_g0d 
    294  
    295  
    296    SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2,   & 
     294   END SUBROUTINE iom_nf90_g0d_sp 
     295 
     296   SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) 
     297      !!----------------------------------------------------------------------- 
     298      !!                  ***  ROUTINE  iom_nf90_g0d  *** 
     299      !! 
     300      !! ** Purpose : read a scalar with NF90 
     301      !!----------------------------------------------------------------------- 
     302      INTEGER ,               INTENT(in   )            ::   kiomid   ! Identifier of the file 
     303      INTEGER ,               INTENT(in   )            ::   kvid     ! variable id 
     304      REAL(dp),               INTENT(  out)            ::   pvar     ! read field 
     305      INTEGER , DIMENSION(1), INTENT(in   ), OPTIONAL  ::   kstart   ! start position of the reading in each axis 
     306      ! 
     307      CHARACTER(LEN=100)      ::   clinfo   ! info character 
     308      !--------------------------------------------------------------------- 
     309      clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 
     310      CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 
     311   END SUBROUTINE iom_nf90_g0d_dp 
     312 
     313   SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2,   & 
    297314         &                    pv_r1d, pv_r2d, pv_r3d ) 
    298315      !!----------------------------------------------------------------------- 
    … …  
    309326      INTEGER , DIMENSION(:)     , INTENT(in   )           ::   kcount    ! number of points to be read in each axis 
    310327      INTEGER ,                    INTENT(in   )           ::   kx1, kx2, ky1, ky2   ! subdomain indexes 
    311       REAL(wp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d    ! read field (1D case) 
    312       REAL(wp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d    ! read field (2D case) 
    313       REAL(wp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d    ! read field (3D case) 
     328      REAL(dp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d    ! read field (1D case) 
     329      REAL(dp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d    ! read field (2D case) 
     330      REAL(dp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d    ! read field (3D case) 
    314331      ! 
    315332      CHARACTER(LEN=100) ::   clinfo               ! info character 
    … …  
    332349      ENDIF 
    333350      ! 
    334    END SUBROUTINE iom_nf90_g123d 
     351   END SUBROUTINE iom_nf90_g123d_dp 
     352 
    335353 
    336354 
    … …  
    506524   END SUBROUTINE iom_nf90_putatt 
    507525 
    508  
    509    SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid  , ktype,   & 
     526   SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid  , ktype,   & 
    510527         &                                  pv_r0d, pv_r1d, pv_r2d, pv_r3d ) 
    511528      !!-------------------------------------------------------------------- 
    … …  
    520537      INTEGER                     , INTENT(in)           ::   kvid     ! variable id 
    521538      INTEGER                     , INTENT(in), OPTIONAL ::   ktype    ! variable type (default R8) 
    522       REAL(wp)                    , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
    523       REAL(wp), DIMENSION(      :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
    524       REAL(wp), DIMENSION(:, :   ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
    525       REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
     539      REAL(dp)                    , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
     540      REAL(dp), DIMENSION(      :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
     541      REAL(dp), DIMENSION(:, :   ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
     542      REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
    526543      ! 
    527544      INTEGER               :: idims                ! number of dimension 
    … …  
    704721      ENDIF 
    705722      !      
    706    END SUBROUTINE iom_nf90_rp0123d 
     723   END SUBROUTINE iom_nf90_rp0123d_dp 
    707724 
    708725 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ISF/isfcav.F90

    r12724 r13228  
    136136      ! 
    137137      ! lbclnk on melt 
    138       CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1., pqfwf, 'T', 1.) 
     138      CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 
    139139      ! 
    140140      ! output fluxes 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ISF/isfcpl.F90

    r12732 r13228  
    212212         zssmask0(:,:) = zssmask_b(:,:) 
    213213         ! 
    214          CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1., zssmask0, 'T', 1. ) 
     214         CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp ) 
    215215         ! 
    216216      END DO 
    … …  
    367367         ztmask0(:,:,:) = ztmask1(:,:,:) 
    368368         ! 
    369          CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1., zts0(:,:,:,jp_sal), 'T', 1., ztmask0, 'T', 1.) 
     369         CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp) 
    370370         ! 
    371371      END DO  ! nn_drown 
    … …  
    458458      END_2D 
    459459      ! 
    460       CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1. ) 
     460      CALL lbc_lnk( 'iscpl', risfcpl_vol, 'T', 1.0_wp ) 
    461461      ! 
    462462      ! 3.0: set total correction (div, tr(:,:,:,:,Krhs), ssh) 
    … …  
    630630                  ELSE IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN 
    631631                     ! spread correction amoung neigbourg wet cells (vertical direction) 
    632                      CALL update_isfpts(zisfpts, jisf, ji  , jj  , jk+1, zdvol, zdsal, zdtem, 1., 0) 
     632                     CALL update_isfpts(zisfpts, jisf, ji  , jj  , jk+1, zdvol, zdsal, zdtem, 1.0_wp, 0) 
    633633                  ELSE 
    634634                     ! need to find where to put correction in later on 
    635                      CALL update_isfpts(zisfpts, jisf, ji  , jj  , jk  , zdvol, zdsal, zdtem, 1., 1) 
     635                     CALL update_isfpts(zisfpts, jisf, ji  , jj  , jk  , zdvol, zdsal, zdtem, 1.0_wp, 1) 
    636636                  END IF 
    637637               END IF 
    … …  
    693693      ! 
    694694      ! add lbclnk 
    695       CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1., risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1., & 
    696          &                            risfcpl_cons_vol(:,:,:)       , 'T', 1.) 
     695      CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & 
     696         &                            risfcpl_cons_vol(:,:,:)       , 'T', 1.0_wp) 
    697697      ! 
    698698      ! ssh correction (for dynspg_ts) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ISF/isfpar.F90

    r12724 r13228  
    8282      ! 
    8383      ! lbclnk on melt and heat fluxes 
    84       CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1., pqfwf, 'T', 1.) 
     84      CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 
    8585      ! 
    8686      ! output fluxes 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r11536 r13228  
    1 #if defined DIM_2d 
    2 #   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j) 
    3 #   define PTR_TYPE              TYPE(PTR_2D) 
    4 #   define PTR_ptab              pt2d 
    5 #endif 
    6 #if defined DIM_3d 
    7 #   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j,k) 
    8 #   define PTR_TYPE              TYPE(PTR_3D) 
    9 #   define PTR_ptab              pt3d 
    10 #endif 
    11 #if defined DIM_4d 
    12 #   define ARRAY_TYPE(i,j,k,l)   REAL(wp), DIMENSION(i,j,k,l) 
    13 #   define PTR_TYPE              TYPE(PTR_4D) 
    14 #   define PTR_ptab              pt4d 
     1#if defined SINGLE_PRECISION 
     2#   if defined DIM_2d 
     3#      define ARRAY_TYPE(i,j,k,l)   REAL(sp), DIMENSION(i,j) 
     4#      define PTR_TYPE              TYPE(PTR_2D_sp) 
     5#      define PTR_ptab              pt2d 
     6#   endif 
     7#   if defined DIM_3d 
     8#      define ARRAY_TYPE(i,j,k,l)   REAL(sp), DIMENSION(i,j,k) 
     9#      define PTR_TYPE              TYPE(PTR_3D_sp) 
     10#      define PTR_ptab              pt3d 
     11#   endif 
     12#   if defined DIM_4d 
     13#      define ARRAY_TYPE(i,j,k,l)   REAL(sp), DIMENSION(i,j,k,l) 
     14#      define PTR_TYPE              TYPE(PTR_4D_sp) 
     15#      define PTR_ptab              pt4d 
     16#   endif 
     17#   define PRECISION sp 
     18#else 
     19#   if defined DIM_2d 
     20#      define ARRAY_TYPE(i,j,k,l)   REAL(dp), DIMENSION(i,j) 
     21#      define PTR_TYPE              TYPE(PTR_2D_dp) 
     22#      define PTR_ptab              pt2d 
     23#   endif 
     24#   if defined DIM_3d 
     25#      define ARRAY_TYPE(i,j,k,l)   REAL(dp), DIMENSION(i,j,k) 
     26#      define PTR_TYPE              TYPE(PTR_3D_dp) 
     27#      define PTR_ptab              pt3d 
     28#   endif 
     29#   if defined DIM_4d 
     30#      define ARRAY_TYPE(i,j,k,l)   REAL(dp), DIMENSION(i,j,k,l) 
     31#      define PTR_TYPE              TYPE(PTR_4D_dp) 
     32#      define PTR_ptab              pt4d 
     33#   endif 
     34#   define PRECISION dp 
    1535#endif 
    1636 
    … …  
    7999   END SUBROUTINE ROUTINE_LOAD 
    80100 
     101#undef PRECISION 
    81102#undef ARRAY_TYPE 
    82103#undef PTR_TYPE 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_nfd_ext_generic.h90

    r10525 r13228  
    88#   define L_SIZE(ptab)          1 
    99#endif 
    10 #define ARRAY_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     10#if defined SINGLE_PRECISION 
     11#   define ARRAY_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     12#   define PRECISION sp 
     13#else 
     14#   define ARRAY_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     15#   define PRECISION dp 
     16#endif 
    1117 
    1218   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj ) 
    … …  
    149155   END SUBROUTINE ROUTINE_NFD 
    150156 
     157#undef PRECISION 
    151158#undef ARRAY_TYPE 
    152159#undef ARRAY_IN 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_nfd_generic.h90

    r10425 r13228  
    44#   define F_SIZE(ptab)             kfld 
    55#   if defined DIM_2d 
    6 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D),INTENT(inout)::ptab(f) 
     6#      if defined SINGLE_PRECISION 
     7#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 
     8#      else 
     9#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 
     10#      endif 
    711#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    812#      define K_SIZE(ptab)             1 
    … …  
    1014#   endif 
    1115#   if defined DIM_3d 
    12 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f) 
     16#      if defined SINGLE_PRECISION 
     17#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 
     18#      else 
     19#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 
     20#      endif 
    1321#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1422#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1624#   endif 
    1725#   if defined DIM_4d 
    18 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f) 
     26#      if defined SINGLE_PRECISION 
     27#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 
     28#      else 
     29#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 
     30#      endif 
    1931#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2032#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    … …  
    4153#      define L_SIZE(ptab)          SIZE(ptab,4) 
    4254#   endif 
    43 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     55#   if defined SINGLE_PRECISION 
     56#      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     57#   else 
     58#      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     59#   endif 
    4460#endif 
     61 
     62#   if defined SINGLE_PRECISION 
     63#      define PRECISION sp 
     64#   else 
     65#      define PRECISION dp 
     66#   endif 
    4567 
    4668#if defined MULTI 
    … …  
    167189   END SUBROUTINE ROUTINE_NFD 
    168190 
     191#undef PRECISION 
    169192#undef ARRAY_TYPE 
    170193#undef ARRAY_IN 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r11536 r13228  
    44#   define F_SIZE(ptab)             kfld 
    55#   if defined DIM_2d 
    6 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D),INTENT(inout)::ptab(f) 
     6#      if defined SINGLE_PRECISION 
     7#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 
     8#      else 
     9#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 
     10#      endif  
    711#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    812#      define K_SIZE(ptab)             1 
    … …  
    1014#   endif 
    1115#   if defined DIM_3d 
    12 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f) 
     16#      if defined SINGLE_PRECISION 
     17#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 
     18#      else 
     19#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 
     20#      endif  
    1321#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1422#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1624#   endif 
    1725#   if defined DIM_4d 
    18 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f) 
     26#      if defined SINGLE_PRECISION 
     27#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 
     28#      else 
     29#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 
     30#      endif  
    1931#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2032#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    2133#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
    2234#   endif 
    23 #   define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D),INTENT(inout)::ptab2(f) 
     35#   if defined SINGLE_PRECISION 
     36#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 
     37#   else 
     38#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 
     39#   endif 
    2440#   define J_SIZE(ptab2)            SIZE(ptab2(1)%pt4d,2) 
    2541#   define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l) 
    … …  
    4662#   define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l) 
    4763#   define J_SIZE(ptab2)             SIZE(ptab2,2) 
    48 #   define ARRAY_TYPE(i,j,k,l,f)     REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    49 #   define ARRAY2_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
    50 #endif 
    51  
     64#   if defined SINGLE_PRECISION 
     65#      define ARRAY_TYPE(i,j,k,l,f)     REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     66#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
     67#   else 
     68#      define ARRAY_TYPE(i,j,k,l,f)     REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
     69#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
     70#   endif 
     71#   endif 
     72#   ifdef SINGLE_PRECISION 
     73#      define PRECISION sp 
     74#   else 
     75#      define PRECISION dp 
     76#   endif 
    5277   SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 
    5378      !!---------------------------------------------------------------------- 
    … …  
    345370      END DO            ! End jf loop 
    346371   END SUBROUTINE ROUTINE_NFD 
     372#undef PRECISION 
    347373#undef ARRAY_TYPE 
    348374#undef ARRAY_IN 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbclnk.F90

    r12377 r13228  
    2828 
    2929   INTERFACE lbc_lnk 
    30       MODULE PROCEDURE   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d 
     30      MODULE PROCEDURE   mpp_lnk_2d_sp   , mpp_lnk_3d_sp   , mpp_lnk_4d_sp 
     31      MODULE PROCEDURE   mpp_lnk_2d_dp   , mpp_lnk_3d_dp   , mpp_lnk_4d_dp 
    3132   END INTERFACE 
    3233   INTERFACE lbc_lnk_ptr 
    33       MODULE PROCEDURE   mpp_lnk_2d_ptr  , mpp_lnk_3d_ptr  , mpp_lnk_4d_ptr 
     34      MODULE PROCEDURE   mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 
     35      MODULE PROCEDURE   mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 
    3436   END INTERFACE 
    3537   INTERFACE lbc_lnk_multi 
    36       MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
     38      MODULE PROCEDURE   lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 
     39      MODULE PROCEDURE   lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 
    3740   END INTERFACE 
    3841   ! 
    3942   INTERFACE lbc_lnk_icb 
    40       MODULE PROCEDURE mpp_lnk_2d_icb 
     43      MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp 
    4144   END INTERFACE 
    4245 
    4346   INTERFACE mpp_nfd 
    44       MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
    45       MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     47      MODULE PROCEDURE   mpp_nfd_2d_sp    , mpp_nfd_3d_sp    , mpp_nfd_4d_sp 
     48      MODULE PROCEDURE   mpp_nfd_2d_dp    , mpp_nfd_3d_dp    , mpp_nfd_4d_dp 
     49      MODULE PROCEDURE   mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp 
     50      MODULE PROCEDURE   mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp 
     51       
    4652   END INTERFACE 
    4753 
    … …  
    9298   !!---------------------------------------------------------------------- 
    9399 
    94 #  define DIM_2d 
    95 #     define ROUTINE_LOAD           load_ptr_2d 
    96 #     define ROUTINE_MULTI          lbc_lnk_2d_multi 
    97 #     include "lbc_lnk_multi_generic.h90" 
    98 #     undef ROUTINE_MULTI 
    99 #     undef ROUTINE_LOAD 
    100 #  undef DIM_2d 
    101  
    102 #  define DIM_3d 
    103 #     define ROUTINE_LOAD           load_ptr_3d 
    104 #     define ROUTINE_MULTI          lbc_lnk_3d_multi 
    105 #     include "lbc_lnk_multi_generic.h90" 
    106 #     undef ROUTINE_MULTI 
    107 #     undef ROUTINE_LOAD 
    108 #  undef DIM_3d 
    109  
    110 #  define DIM_4d 
    111 #     define ROUTINE_LOAD           load_ptr_4d 
    112 #     define ROUTINE_MULTI          lbc_lnk_4d_multi 
     100   !! 
     101   !!   ----   SINGLE PRECISION VERSIONS 
     102   !! 
     103#  define SINGLE_PRECISION 
     104#  define DIM_2d 
     105#     define ROUTINE_LOAD           load_ptr_2d_sp 
     106#     define ROUTINE_MULTI          lbc_lnk_2d_multi_sp 
     107#     include "lbc_lnk_multi_generic.h90" 
     108#     undef ROUTINE_MULTI 
     109#     undef ROUTINE_LOAD 
     110#  undef DIM_2d 
     111 
     112#  define DIM_3d 
     113#     define ROUTINE_LOAD           load_ptr_3d_sp 
     114#     define ROUTINE_MULTI          lbc_lnk_3d_multi_sp 
     115#     include "lbc_lnk_multi_generic.h90" 
     116#     undef ROUTINE_MULTI 
     117#     undef ROUTINE_LOAD 
     118#  undef DIM_3d 
     119 
     120#  define DIM_4d 
     121#     define ROUTINE_LOAD           load_ptr_4d_sp 
     122#     define ROUTINE_MULTI          lbc_lnk_4d_multi_sp 
     123#     include "lbc_lnk_multi_generic.h90" 
     124#     undef ROUTINE_MULTI 
     125#     undef ROUTINE_LOAD 
     126#  undef DIM_4d 
     127#  undef SINGLE_PRECISION 
     128   !! 
     129   !!   ----   DOUBLE PRECISION VERSIONS 
     130   !! 
     131 
     132#  define DIM_2d 
     133#     define ROUTINE_LOAD           load_ptr_2d_dp 
     134#     define ROUTINE_MULTI          lbc_lnk_2d_multi_dp 
     135#     include "lbc_lnk_multi_generic.h90" 
     136#     undef ROUTINE_MULTI 
     137#     undef ROUTINE_LOAD 
     138#  undef DIM_2d 
     139 
     140#  define DIM_3d 
     141#     define ROUTINE_LOAD           load_ptr_3d_dp 
     142#     define ROUTINE_MULTI          lbc_lnk_3d_multi_dp 
     143#     include "lbc_lnk_multi_generic.h90" 
     144#     undef ROUTINE_MULTI 
     145#     undef ROUTINE_LOAD 
     146#  undef DIM_3d 
     147 
     148#  define DIM_4d 
     149#     define ROUTINE_LOAD           load_ptr_4d_dp 
     150#     define ROUTINE_MULTI          lbc_lnk_4d_multi_dp 
    113151#     include "lbc_lnk_multi_generic.h90" 
    114152#     undef ROUTINE_MULTI 
    … …  
    130168   !                       !==  2D array and array of 2D pointer  ==! 
    131169   ! 
    132 #  define DIM_2d 
    133 #     define ROUTINE_LNK           mpp_lnk_2d 
    134 #     include "mpp_lnk_generic.h90" 
    135 #     undef ROUTINE_LNK 
    136 #     define MULTI 
    137 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     170   !! 
     171   !!   ----   SINGLE PRECISION VERSIONS 
     172   !! 
     173# define SINGLE_PRECISION 
     174#  define DIM_2d 
     175#     define ROUTINE_LNK           mpp_lnk_2d_sp 
     176#     include "mpp_lnk_generic.h90" 
     177#     undef ROUTINE_LNK 
     178#     define MULTI 
     179#     define ROUTINE_LNK           mpp_lnk_2d_ptr_sp 
    138180#     include "mpp_lnk_generic.h90" 
    139181#     undef ROUTINE_LNK 
    … …  
    144186   ! 
    145187#  define DIM_3d 
    146 #     define ROUTINE_LNK           mpp_lnk_3d 
    147 #     include "mpp_lnk_generic.h90" 
    148 #     undef ROUTINE_LNK 
    149 #     define MULTI 
    150 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     188#     define ROUTINE_LNK           mpp_lnk_3d_sp 
     189#     include "mpp_lnk_generic.h90" 
     190#     undef ROUTINE_LNK 
     191#     define MULTI 
     192#     define ROUTINE_LNK           mpp_lnk_3d_ptr_sp 
    151193#     include "mpp_lnk_generic.h90" 
    152194#     undef ROUTINE_LNK 
    … …  
    157199   ! 
    158200#  define DIM_4d 
    159 #     define ROUTINE_LNK           mpp_lnk_4d 
    160 #     include "mpp_lnk_generic.h90" 
    161 #     undef ROUTINE_LNK 
    162 #     define MULTI 
    163 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    164 #     include "mpp_lnk_generic.h90" 
    165 #     undef ROUTINE_LNK 
    166 #     undef MULTI 
    167 #  undef DIM_4d 
     201#     define ROUTINE_LNK           mpp_lnk_4d_sp 
     202#     include "mpp_lnk_generic.h90" 
     203#     undef ROUTINE_LNK 
     204#     define MULTI 
     205#     define ROUTINE_LNK           mpp_lnk_4d_ptr_sp 
     206#     include "mpp_lnk_generic.h90" 
     207#     undef ROUTINE_LNK 
     208#     undef MULTI 
     209#  undef DIM_4d 
     210# undef SINGLE_PRECISION 
     211 
     212   !! 
     213   !!   ----   DOUBLE PRECISION VERSIONS 
     214   !! 
     215#  define DIM_2d 
     216#     define ROUTINE_LNK           mpp_lnk_2d_dp 
     217#     include "mpp_lnk_generic.h90" 
     218#     undef ROUTINE_LNK 
     219#     define MULTI 
     220#     define ROUTINE_LNK           mpp_lnk_2d_ptr_dp 
     221#     include "mpp_lnk_generic.h90" 
     222#     undef ROUTINE_LNK 
     223#     undef MULTI 
     224#  undef DIM_2d 
     225   ! 
     226   !                       !==  3D array and array of 3D pointer  ==! 
     227   ! 
     228#  define DIM_3d 
     229#     define ROUTINE_LNK           mpp_lnk_3d_dp 
     230#     include "mpp_lnk_generic.h90" 
     231#     undef ROUTINE_LNK 
     232#     define MULTI 
     233#     define ROUTINE_LNK           mpp_lnk_3d_ptr_dp 
     234#     include "mpp_lnk_generic.h90" 
     235#     undef ROUTINE_LNK 
     236#     undef MULTI 
     237#  undef DIM_3d 
     238   ! 
     239   !                       !==  4D array and array of 4D pointer  ==! 
     240   ! 
     241#  define DIM_4d 
     242#     define ROUTINE_LNK           mpp_lnk_4d_dp 
     243#     include "mpp_lnk_generic.h90" 
     244#     undef ROUTINE_LNK 
     245#     define MULTI 
     246#     define ROUTINE_LNK           mpp_lnk_4d_ptr_dp 
     247#     include "mpp_lnk_generic.h90" 
     248#     undef ROUTINE_LNK 
     249#     undef MULTI 
     250#  undef DIM_4d 
     251 
    168252 
    169253   !!---------------------------------------------------------------------- 
    … …  
    181265   !                       !==  2D array and array of 2D pointer  ==! 
    182266   ! 
    183 #  define DIM_2d 
    184 #     define ROUTINE_NFD           mpp_nfd_2d 
    185 #     include "mpp_nfd_generic.h90" 
    186 #     undef ROUTINE_NFD 
    187 #     define MULTI 
    188 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     267   !! 
     268   !!   ----   SINGLE PRECISION VERSIONS 
     269   !! 
     270#  define SINGLE_PRECISION 
     271#  define DIM_2d 
     272#     define ROUTINE_NFD           mpp_nfd_2d_sp 
     273#     include "mpp_nfd_generic.h90" 
     274#     undef ROUTINE_NFD 
     275#     define MULTI 
     276#     define ROUTINE_NFD           mpp_nfd_2d_ptr_sp 
    189277#     include "mpp_nfd_generic.h90" 
    190278#     undef ROUTINE_NFD 
    … …  
    195283   ! 
    196284#  define DIM_3d 
    197 #     define ROUTINE_NFD           mpp_nfd_3d 
    198 #     include "mpp_nfd_generic.h90" 
    199 #     undef ROUTINE_NFD 
    200 #     define MULTI 
    201 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     285#     define ROUTINE_NFD           mpp_nfd_3d_sp 
     286#     include "mpp_nfd_generic.h90" 
     287#     undef ROUTINE_NFD 
     288#     define MULTI 
     289#     define ROUTINE_NFD           mpp_nfd_3d_ptr_sp 
    202290#     include "mpp_nfd_generic.h90" 
    203291#     undef ROUTINE_NFD 
    … …  
    208296   ! 
    209297#  define DIM_4d 
    210 #     define ROUTINE_NFD           mpp_nfd_4d 
    211 #     include "mpp_nfd_generic.h90" 
    212 #     undef ROUTINE_NFD 
    213 #     define MULTI 
    214 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    215 #     include "mpp_nfd_generic.h90" 
    216 #     undef ROUTINE_NFD 
    217 #     undef MULTI 
    218 #  undef DIM_4d 
    219  
     298#     define ROUTINE_NFD           mpp_nfd_4d_sp 
     299#     include "mpp_nfd_generic.h90" 
     300#     undef ROUTINE_NFD 
     301#     define MULTI 
     302#     define ROUTINE_NFD           mpp_nfd_4d_ptr_sp 
     303#     include "mpp_nfd_generic.h90" 
     304#     undef ROUTINE_NFD 
     305#     undef MULTI 
     306#  undef DIM_4d 
     307#  undef SINGLE_PRECISION 
     308 
     309   !! 
     310   !!   ----   DOUBLE PRECISION VERSIONS 
     311   !! 
     312#  define DIM_2d 
     313#     define ROUTINE_NFD           mpp_nfd_2d_dp 
     314#     include "mpp_nfd_generic.h90" 
     315#     undef ROUTINE_NFD 
     316#     define MULTI 
     317#     define ROUTINE_NFD           mpp_nfd_2d_ptr_dp 
     318#     include "mpp_nfd_generic.h90" 
     319#     undef ROUTINE_NFD 
     320#     undef MULTI 
     321#  undef DIM_2d 
     322   ! 
     323   !                       !==  3D array and array of 3D pointer  ==! 
     324   ! 
     325#  define DIM_3d 
     326#     define ROUTINE_NFD           mpp_nfd_3d_dp 
     327#     include "mpp_nfd_generic.h90" 
     328#     undef ROUTINE_NFD 
     329#     define MULTI 
     330#     define ROUTINE_NFD           mpp_nfd_3d_ptr_dp 
     331#     include "mpp_nfd_generic.h90" 
     332#     undef ROUTINE_NFD 
     333#     undef MULTI 
     334#  undef DIM_3d 
     335   ! 
     336   !                       !==  4D array and array of 4D pointer  ==! 
     337   ! 
     338#  define DIM_4d 
     339#     define ROUTINE_NFD           mpp_nfd_4d_dp 
     340#     include "mpp_nfd_generic.h90" 
     341#     undef ROUTINE_NFD 
     342#     define MULTI 
     343#     define ROUTINE_NFD           mpp_nfd_4d_ptr_dp 
     344#     include "mpp_nfd_generic.h90" 
     345#     undef ROUTINE_NFD 
     346#     undef MULTI 
     347#  undef DIM_4d 
    220348 
    221349   !!====================================================================== 
    222350 
    223351 
    224  
    225    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    226       !!--------------------------------------------------------------------- 
     352   !!====================================================================== 
     353     !!--------------------------------------------------------------------- 
    227354      !!                   ***  routine mpp_lbc_north_icb  *** 
    228355      !! 
    … …  
    240367      !! 
    241368      !!---------------------------------------------------------------------- 
    242       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    243       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    244       !                                                     !   = T ,  U , V , F or W -points 
    245       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    246       !!                                                    ! north fold, =  1. otherwise 
    247       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    248       ! 
    249       INTEGER ::   ji, jj, jr 
    250       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    251       INTEGER ::   ipj, ij, iproc 
    252       ! 
    253       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    254       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    255       !!---------------------------------------------------------------------- 
    256 #if defined key_mpp_mpi 
    257       ! 
    258       ipj=4 
    259       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    260      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    261      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    262       ! 
    263       ztab_e(:,:)      = 0._wp 
    264       znorthloc_e(:,:) = 0._wp 
    265       ! 
    266       ij = 1 - kextj 
    267       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    268       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    269          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    270          ij = ij + 1 
    271       END DO 
    272       ! 
    273       itaille = jpimax * ( ipj + 2*kextj ) 
    274       ! 
    275       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    276       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    277          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    278          &                ncomm_north, ierr ) 
    279       ! 
    280       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    281       ! 
    282       DO jr = 1, ndim_rank_north            ! recover the global north array 
    283          iproc = nrank_north(jr) + 1 
    284          ildi = nldit (iproc) 
    285          ilei = nleit (iproc) 
    286          iilb = nimppt(iproc) 
    287          DO jj = 1-kextj, ipj+kextj 
    288             DO ji = ildi, ilei 
    289                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    290             END DO 
    291          END DO 
    292       END DO 
    293  
    294       ! 2. North-Fold boundary conditions 
    295       ! ---------------------------------- 
    296       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    297  
    298       ij = 1 - kextj 
    299       !! Scatter back to pt2d 
    300       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    301          DO ji= 1, jpi 
    302             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    303          END DO 
    304          ij  = ij +1 
    305       END DO 
    306       ! 
    307       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    308       ! 
    309 #endif 
    310    END SUBROUTINE mpp_lbc_north_icb 
    311  
    312  
    313    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
     369#     define SINGLE_PRECISION 
     370#     define ROUTINE_LNK           mpp_lbc_north_icb_sp 
     371#     include "mpp_lbc_north_icb_generic.h90" 
     372#     undef ROUTINE_LNK 
     373#     undef SINGLE_PRECISION 
     374#     define ROUTINE_LNK           mpp_lbc_north_icb_dp 
     375#     include "mpp_lbc_north_icb_generic.h90" 
     376#     undef ROUTINE_LNK 
     377  
     378 
    314379      !!---------------------------------------------------------------------- 
    315380      !!                  ***  routine mpp_lnk_2d_icb  *** 
    … …  
    333398      !!                    nono   : number for local neighboring processors 
    334399      !!---------------------------------------------------------------------- 
    335       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    336       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    337       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    338       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    339       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    340       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    341       ! 
    342       INTEGER  ::   jl   ! dummy loop indices 
    343       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    344       INTEGER  ::   ipreci, iprecj             !   -       - 
    345       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    346       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    347       !! 
    348       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    349       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    350       !!---------------------------------------------------------------------- 
    351  
    352       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    353       iprecj = nn_hls + kextj 
    354  
    355       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    356  
    357       ! 1. standard boundary treatment 
    358       ! ------------------------------ 
    359       ! Order matters Here !!!! 
    360       ! 
    361       !                                      ! East-West boundaries 
    362       !                                           !* Cyclic east-west 
    363       IF( l_Iperio ) THEN 
    364          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    365          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    366          ! 
    367       ELSE                                        !* closed 
    368          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    369                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    370       ENDIF 
    371       !                                      ! North-South boundaries 
    372       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    373          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    374          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    375       ELSE                                        !* closed 
    376          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    377                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    378       ENDIF 
    379       ! 
    380  
    381       ! north fold treatment 
    382       ! ----------------------- 
    383       IF( npolj /= 0 ) THEN 
    384          ! 
    385          SELECT CASE ( jpni ) 
    386                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    387                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    388          END SELECT 
    389          ! 
    390       ENDIF 
    391  
    392       ! 2. East and west directions exchange 
    393       ! ------------------------------------ 
    394       ! we play with the neigbours AND the row number because of the periodicity 
    395       ! 
    396       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    397       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    398          iihom = jpi-nreci-kexti 
    399          DO jl = 1, ipreci 
    400             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    401             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    402          END DO 
    403       END SELECT 
    404       ! 
    405       !                           ! Migrations 
    406       imigr = ipreci * ( jpj + 2*kextj ) 
    407       ! 
    408       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    409       ! 
    410       SELECT CASE ( nbondi ) 
    411       CASE ( -1 ) 
    412          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    413          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    414          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    415       CASE ( 0 ) 
    416          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    417          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    418          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    419          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    420          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    421          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    422       CASE ( 1 ) 
    423          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    424          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    425          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    426       END SELECT 
    427       ! 
    428       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    429       ! 
    430       !                           ! Write Dirichlet lateral conditions 
    431       iihom = jpi - nn_hls 
    432       ! 
    433       SELECT CASE ( nbondi ) 
    434       CASE ( -1 ) 
    435          DO jl = 1, ipreci 
    436             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    437          END DO 
    438       CASE ( 0 ) 
    439          DO jl = 1, ipreci 
    440             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    441             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    442          END DO 
    443       CASE ( 1 ) 
    444          DO jl = 1, ipreci 
    445             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    446          END DO 
    447       END SELECT 
    448  
    449  
    450       ! 3. North and south directions 
    451       ! ----------------------------- 
    452       ! always closed : we play only with the neigbours 
    453       ! 
    454       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    455          ijhom = jpj-nrecj-kextj 
    456          DO jl = 1, iprecj 
    457             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    458             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    459          END DO 
    460       ENDIF 
    461       ! 
    462       !                           ! Migrations 
    463       imigr = iprecj * ( jpi + 2*kexti ) 
    464       ! 
    465       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    466       ! 
    467       SELECT CASE ( nbondj ) 
    468       CASE ( -1 ) 
    469          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    470          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    471          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    472       CASE ( 0 ) 
    473          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    474          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    475          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    476          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    477          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    478          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    479       CASE ( 1 ) 
    480          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    481          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    482          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    483       END SELECT 
    484       ! 
    485       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    486       ! 
    487       !                           ! Write Dirichlet lateral conditions 
    488       ijhom = jpj - nn_hls 
    489       ! 
    490       SELECT CASE ( nbondj ) 
    491       CASE ( -1 ) 
    492          DO jl = 1, iprecj 
    493             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    494          END DO 
    495       CASE ( 0 ) 
    496          DO jl = 1, iprecj 
    497             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    498             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    499          END DO 
    500       CASE ( 1 ) 
    501          DO jl = 1, iprecj 
    502             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    503          END DO 
    504       END SELECT 
    505       ! 
    506    END SUBROUTINE mpp_lnk_2d_icb 
    507     
     400 
     401#     define SINGLE_PRECISION 
     402#     define ROUTINE_LNK           mpp_lnk_2d_icb_sp 
     403#     include "mpp_lnk_icb_generic.h90" 
     404#     undef ROUTINE_LNK 
     405#     undef SINGLE_PRECISION 
     406#     define ROUTINE_LNK           mpp_lnk_2d_icb_dp 
     407#     include "mpp_lnk_icb_generic.h90" 
     408#     undef ROUTINE_LNK 
     409   
    508410END MODULE lbclnk 
    509411 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lbcnfd.F90

    r11536 r13228  
    2626 
    2727   INTERFACE lbc_nfd 
    28       MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d 
    29       MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr 
    30       MODULE PROCEDURE   lbc_nfd_2d_ext 
     28      MODULE PROCEDURE   lbc_nfd_2d_sp    , lbc_nfd_3d_sp    , lbc_nfd_4d_sp 
     29      MODULE PROCEDURE   lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 
     30      MODULE PROCEDURE   lbc_nfd_2d_ext_sp 
     31      MODULE PROCEDURE   lbc_nfd_2d_dp    , lbc_nfd_3d_dp    , lbc_nfd_4d_dp 
     32      MODULE PROCEDURE   lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 
     33      MODULE PROCEDURE   lbc_nfd_2d_ext_dp 
    3134   END INTERFACE 
    3235   ! 
    3336   INTERFACE lbc_nfd_nogather 
    3437!                        ! Currently only 4d array version is needed 
    35      MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d 
    36      MODULE PROCEDURE   lbc_nfd_nogather_4d 
    37      MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 
     38     MODULE PROCEDURE   lbc_nfd_nogather_2d_sp    , lbc_nfd_nogather_3d_sp 
     39     MODULE PROCEDURE   lbc_nfd_nogather_4d_sp 
     40     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 
     41     MODULE PROCEDURE   lbc_nfd_nogather_2d_dp    , lbc_nfd_nogather_3d_dp 
     42     MODULE PROCEDURE   lbc_nfd_nogather_4d_dp 
     43     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 
    3844!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr 
    3945   END INTERFACE 
    4046 
    41    TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp) 
    42       REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d 
    43    END TYPE PTR_2D 
    44    TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp) 
    45       REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
    46    END TYPE PTR_3D 
    47    TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp) 
    48       REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
    49    END TYPE PTR_4D 
     47   TYPE, PUBLIC ::   PTR_2D_dp   !: array of 2D pointers (also used in lib_mpp) 
     48      REAL(dp), DIMENSION (:,:)    , POINTER ::   pt2d 
     49   END TYPE PTR_2D_dp 
     50   TYPE, PUBLIC ::   PTR_3D_dp   !: array of 3D pointers (also used in lib_mpp) 
     51      REAL(dp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     52   END TYPE PTR_3D_dp 
     53   TYPE, PUBLIC ::   PTR_4D_dp   !: array of 4D pointers (also used in lib_mpp) 
     54      REAL(dp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     55   END TYPE PTR_4D_dp 
     56 
     57   TYPE, PUBLIC ::   PTR_2D_sp   !: array of 2D pointers (also used in lib_mpp) 
     58      REAL(sp), DIMENSION (:,:)    , POINTER ::   pt2d 
     59   END TYPE PTR_2D_sp 
     60   TYPE, PUBLIC ::   PTR_3D_sp   !: array of 3D pointers (also used in lib_mpp) 
     61      REAL(sp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
     62   END TYPE PTR_3D_sp 
     63   TYPE, PUBLIC ::   PTR_4D_sp   !: array of 4D pointers (also used in lib_mpp) 
     64      REAL(sp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     65   END TYPE PTR_4D_sp 
     66 
    5067 
    5168   PUBLIC   lbc_nfd            ! north fold conditions 
    … …  
    7592   !!---------------------------------------------------------------------- 
    7693   ! 
    77    !                       !==  2D array and array of 2D pointer  ==! 
    78    ! 
    79 #  define DIM_2d 
    80 #     define ROUTINE_NFD           lbc_nfd_2d 
    81 #     include "lbc_nfd_generic.h90" 
    82 #     undef ROUTINE_NFD 
    83 #     define MULTI 
    84 #     define ROUTINE_NFD           lbc_nfd_2d_ptr 
     94   !                       !==  SINGLE PRECISION VERSIONS 
     95   ! 
     96   ! 
     97   !                       !==  2D array and array of 2D pointer  ==! 
     98   ! 
     99#  define SINGLE_PRECISION 
     100#  define DIM_2d 
     101#     define ROUTINE_NFD           lbc_nfd_2d_sp 
     102#     include "lbc_nfd_generic.h90" 
     103#     undef ROUTINE_NFD 
     104#     define MULTI 
     105#     define ROUTINE_NFD           lbc_nfd_2d_ptr_sp 
    85106#     include "lbc_nfd_generic.h90" 
    86107#     undef ROUTINE_NFD 
    … …  
    91112   ! 
    92113#  define DIM_2d 
    93 #     define ROUTINE_NFD           lbc_nfd_2d_ext 
     114#     define ROUTINE_NFD           lbc_nfd_2d_ext_sp 
    94115#     include "lbc_nfd_ext_generic.h90" 
    95116#     undef ROUTINE_NFD 
    … …  
    99120   ! 
    100121#  define DIM_3d 
    101 #     define ROUTINE_NFD           lbc_nfd_3d 
    102 #     include "lbc_nfd_generic.h90" 
    103 #     undef ROUTINE_NFD 
    104 #     define MULTI 
    105 #     define ROUTINE_NFD           lbc_nfd_3d_ptr 
    106 #     include "lbc_nfd_generic.h90" 
    107 #     undef ROUTINE_NFD 
    108 #     undef MULTI 
    109 #  undef DIM_3d 
    110    ! 
    111    !                       !==  4D array and array of 4D pointer  ==! 
    112    ! 
    113 #  define DIM_4d 
    114 #     define ROUTINE_NFD           lbc_nfd_4d 
    115 #     include "lbc_nfd_generic.h90" 
    116 #     undef ROUTINE_NFD 
    117 #     define MULTI 
    118 #     define ROUTINE_NFD           lbc_nfd_4d_ptr 
     122#     define ROUTINE_NFD           lbc_nfd_3d_sp 
     123#     include "lbc_nfd_generic.h90" 
     124#     undef ROUTINE_NFD 
     125#     define MULTI 
     126#     define ROUTINE_NFD           lbc_nfd_3d_ptr_sp 
     127#     include "lbc_nfd_generic.h90" 
     128#     undef ROUTINE_NFD 
     129#     undef MULTI 
     130#  undef DIM_3d 
     131   ! 
     132   !                       !==  4D array and array of 4D pointer  ==! 
     133   ! 
     134#  define DIM_4d 
     135#     define ROUTINE_NFD           lbc_nfd_4d_sp 
     136#     include "lbc_nfd_generic.h90" 
     137#     undef ROUTINE_NFD 
     138#     define MULTI 
     139#     define ROUTINE_NFD           lbc_nfd_4d_ptr_sp 
    119140#     include "lbc_nfd_generic.h90" 
    120141#     undef ROUTINE_NFD 
    … …  
    127148   ! 
    128149#  define DIM_2d 
    129 #     define ROUTINE_NFD           lbc_nfd_nogather_2d 
    130 #     include "lbc_nfd_nogather_generic.h90" 
    131 #     undef ROUTINE_NFD 
    132 #     define MULTI 
    133 #     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr 
    134 #     include "lbc_nfd_nogather_generic.h90" 
    135 #     undef ROUTINE_NFD 
    136 #     undef MULTI 
    137 #  undef DIM_2d 
    138    ! 
    139    !                       !==  3D array and array of 3D pointer  ==! 
    140    ! 
    141 #  define DIM_3d 
    142 #     define ROUTINE_NFD           lbc_nfd_nogather_3d 
    143 #     include "lbc_nfd_nogather_generic.h90" 
    144 #     undef ROUTINE_NFD 
    145 #     define MULTI 
    146 #     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr 
    147 #     include "lbc_nfd_nogather_generic.h90" 
    148 #     undef ROUTINE_NFD 
    149 #     undef MULTI 
    150 #  undef DIM_3d 
    151    ! 
    152    !                       !==  4D array and array of 4D pointer  ==! 
    153    ! 
    154 #  define DIM_4d 
    155 #     define ROUTINE_NFD           lbc_nfd_nogather_4d 
     150#     define ROUTINE_NFD           lbc_nfd_nogather_2d_sp 
     151#     include "lbc_nfd_nogather_generic.h90" 
     152#     undef ROUTINE_NFD 
     153#     define MULTI 
     154#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr_sp 
     155#     include "lbc_nfd_nogather_generic.h90" 
     156#     undef ROUTINE_NFD 
     157#     undef MULTI 
     158#  undef DIM_2d 
     159   ! 
     160   !                       !==  3D array and array of 3D pointer  ==! 
     161   ! 
     162#  define DIM_3d 
     163#     define ROUTINE_NFD           lbc_nfd_nogather_3d_sp 
     164#     include "lbc_nfd_nogather_generic.h90" 
     165#     undef ROUTINE_NFD 
     166#     define MULTI 
     167#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr_sp 
     168#     include "lbc_nfd_nogather_generic.h90" 
     169#     undef ROUTINE_NFD 
     170#     undef MULTI 
     171#  undef DIM_3d 
     172   ! 
     173   !                       !==  4D array and array of 4D pointer  ==! 
     174   ! 
     175#  define DIM_4d 
     176#     define ROUTINE_NFD           lbc_nfd_nogather_4d_sp 
    156177#     include "lbc_nfd_nogather_generic.h90" 
    157178#     undef ROUTINE_NFD 
    … …  
    162183!#     undef MULTI 
    163184#  undef DIM_4d 
    164  
    165    !!---------------------------------------------------------------------- 
     185#  undef SINGLE_PRECISION 
     186 
     187   !!---------------------------------------------------------------------- 
     188   ! 
     189   !                       !==  DOUBLE PRECISION VERSIONS 
     190   ! 
     191   ! 
     192   !                       !==  2D array and array of 2D pointer  ==! 
     193   ! 
     194#  define DIM_2d 
     195#     define ROUTINE_NFD           lbc_nfd_2d_dp 
     196#     include "lbc_nfd_generic.h90" 
     197#     undef ROUTINE_NFD 
     198#     define MULTI 
     199#     define ROUTINE_NFD           lbc_nfd_2d_ptr_dp 
     200#     include "lbc_nfd_generic.h90" 
     201#     undef ROUTINE_NFD 
     202#     undef MULTI 
     203#  undef DIM_2d 
     204   ! 
     205   !                       !==  2D array with extra haloes  ==! 
     206   ! 
     207#  define DIM_2d 
     208#     define ROUTINE_NFD           lbc_nfd_2d_ext_dp 
     209#     include "lbc_nfd_ext_generic.h90" 
     210#     undef ROUTINE_NFD 
     211#  undef DIM_2d 
     212   ! 
     213   !                       !==  3D array and array of 3D pointer  ==! 
     214   ! 
     215#  define DIM_3d 
     216#     define ROUTINE_NFD           lbc_nfd_3d_dp 
     217#     include "lbc_nfd_generic.h90" 
     218#     undef ROUTINE_NFD 
     219#     define MULTI 
     220#     define ROUTINE_NFD           lbc_nfd_3d_ptr_dp 
     221#     include "lbc_nfd_generic.h90" 
     222#     undef ROUTINE_NFD 
     223#     undef MULTI 
     224#  undef DIM_3d 
     225   ! 
     226   !                       !==  4D array and array of 4D pointer  ==! 
     227   ! 
     228#  define DIM_4d 
     229#     define ROUTINE_NFD           lbc_nfd_4d_dp 
     230#     include "lbc_nfd_generic.h90" 
     231#     undef ROUTINE_NFD 
     232#     define MULTI 
     233#     define ROUTINE_NFD           lbc_nfd_4d_ptr_dp 
     234#     include "lbc_nfd_generic.h90" 
     235#     undef ROUTINE_NFD 
     236#     undef MULTI 
     237#  undef DIM_4d 
     238   ! 
     239   !  lbc_nfd_nogather routines 
     240   ! 
     241   !                       !==  2D array and array of 2D pointer  ==! 
     242   ! 
     243#  define DIM_2d 
     244#     define ROUTINE_NFD           lbc_nfd_nogather_2d_dp 
     245#     include "lbc_nfd_nogather_generic.h90" 
     246#     undef ROUTINE_NFD 
     247#     define MULTI 
     248#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr_dp 
     249#     include "lbc_nfd_nogather_generic.h90" 
     250#     undef ROUTINE_NFD 
     251#     undef MULTI 
     252#  undef DIM_2d 
     253   ! 
     254   !                       !==  3D array and array of 3D pointer  ==! 
     255   ! 
     256#  define DIM_3d 
     257#     define ROUTINE_NFD           lbc_nfd_nogather_3d_dp 
     258#     include "lbc_nfd_nogather_generic.h90" 
     259#     undef ROUTINE_NFD 
     260#     define MULTI 
     261#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr_dp 
     262#     include "lbc_nfd_nogather_generic.h90" 
     263#     undef ROUTINE_NFD 
     264#     undef MULTI 
     265#  undef DIM_3d 
     266   ! 
     267   !                       !==  4D array and array of 4D pointer  ==! 
     268   ! 
     269#  define DIM_4d 
     270#     define ROUTINE_NFD           lbc_nfd_nogather_4d_dp 
     271#     include "lbc_nfd_nogather_generic.h90" 
     272#     undef ROUTINE_NFD 
     273!#     define MULTI 
     274!#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr 
     275!#     include "lbc_nfd_nogather_generic.h90" 
     276!#     undef ROUTINE_NFD 
     277!#     undef MULTI 
     278#  undef DIM_4d 
     279 
     280   !!---------------------------------------------------------------------- 
     281 
    166282 
    167283 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/lib_mpp.F90

    r13219 r13228  
    6767   PUBLIC   mpp_ini_znl 
    6868   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
     69   PUBLIC   mppsend_sp, mpprecv_sp                          ! needed by TAM and ICB routines 
     70   PUBLIC   mppsend_dp, mpprecv_dp                          ! needed by TAM and ICB routines 
    6971   PUBLIC   mpp_report 
    7072   PUBLIC   mpp_bcast_nml 
    … …  
    7981   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 
    8082   INTERFACE mpp_min 
    81       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
     83      MODULE PROCEDURE mppmin_a_int, mppmin_int 
     84      MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp 
     85      MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp 
    8286   END INTERFACE 
    8387   INTERFACE mpp_max 
    84       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
     88      MODULE PROCEDURE mppmax_a_int, mppmax_int 
     89      MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp 
     90      MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp 
    8591   END INTERFACE 
    8692   INTERFACE mpp_sum 
    87       MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   & 
    88          &             mppsum_realdd, mppsum_a_realdd 
     93      MODULE PROCEDURE mppsum_a_int, mppsum_int 
     94      MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd 
     95      MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp 
     96      MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp 
    8997   END INTERFACE 
    9098   INTERFACE mpp_minloc 
    91       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
     99      MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp 
     100      MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp 
    92101   END INTERFACE 
    93102   INTERFACE mpp_maxloc 
    94       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     103      MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp 
     104      MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp 
    95105   END INTERFACE 
    96106 
    … …  
    158168   TYPE, PUBLIC ::   DELAYARR 
    159169      REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    160       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
     170      COMPLEX(dp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    161171   END TYPE DELAYARR 
    162172   TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE  ::   todelay         !: must have SAVE for default initialization of DELAYARR 
    … …  
    164174 
    165175   ! timing summary report 
    166    REAL(wp), DIMENSION(2), PUBLIC ::  waiting_time = 0._wp 
    167    REAL(wp)              , PUBLIC ::  compute_time = 0._wp, elapsed_time = 0._wp 
     176   REAL(dp), DIMENSION(2), PUBLIC ::  waiting_time = 0._dp 
     177   REAL(dp)              , PUBLIC ::  compute_time = 0._dp, elapsed_time = 0._dp 
    168178    
    169179   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE ::   tampon   ! buffer in case of bsend 
    … …  
    251261      !! 
    252262      INTEGER ::   iflag 
     263      INTEGER :: mpi_working_type 
     264      !!---------------------------------------------------------------------- 
     265      ! 
     266#if defined key_mpp_mpi 
     267      IF (wp == dp) THEN 
     268         mpi_working_type = mpi_double_precision 
     269      ELSE 
     270         mpi_working_type = mpi_real 
     271      END IF 
     272      CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     273#endif 
     274      ! 
     275   END SUBROUTINE mppsend 
     276 
     277 
     278   SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) 
     279      !!---------------------------------------------------------------------- 
     280      !!                  ***  routine mppsend  *** 
     281      !! 
     282      !! ** Purpose :   Send messag passing array 
     283      !! 
     284      !!---------------------------------------------------------------------- 
     285      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     286      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     287      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     288      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     289      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     290      !! 
     291      INTEGER ::   iflag 
    253292      !!---------------------------------------------------------------------- 
    254293      ! 
    … …  
    257296#endif 
    258297      ! 
    259    END SUBROUTINE mppsend 
     298   END SUBROUTINE mppsend_dp 
     299 
     300 
     301   SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) 
     302      !!---------------------------------------------------------------------- 
     303      !!                  ***  routine mppsend  *** 
     304      !! 
     305      !! ** Purpose :   Send messag passing array 
     306      !! 
     307      !!---------------------------------------------------------------------- 
     308      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     309      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     310      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     311      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     312      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     313      !! 
     314      INTEGER ::   iflag 
     315      !!---------------------------------------------------------------------- 
     316      ! 
     317#if defined key_mpp_mpi 
     318      CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     319#endif 
     320      ! 
     321   END SUBROUTINE mppsend_sp 
    260322 
    261323 
    … …  
    275337      INTEGER :: iflag 
    276338      INTEGER :: use_source 
     339      INTEGER :: mpi_working_type 
    277340      !!---------------------------------------------------------------------- 
    278341      ! 
    … …  
    283346      IF( PRESENT(ksource) )   use_source = ksource 
    284347      ! 
     348      IF (wp == dp) THEN 
     349         mpi_working_type = mpi_double_precision 
     350      ELSE 
     351         mpi_working_type = mpi_real 
     352      END IF 
     353      CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     354#endif 
     355      ! 
     356   END SUBROUTINE mpprecv 
     357 
     358   SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) 
     359      !!---------------------------------------------------------------------- 
     360      !!                  ***  routine mpprecv  *** 
     361      !! 
     362      !! ** Purpose :   Receive messag passing array 
     363      !! 
     364      !!---------------------------------------------------------------------- 
     365      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     366      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     367      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     368      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     369      !! 
     370      INTEGER :: istatus(mpi_status_size) 
     371      INTEGER :: iflag 
     372      INTEGER :: use_source 
     373      !!---------------------------------------------------------------------- 
     374      ! 
     375#if defined key_mpp_mpi 
     376      ! If a specific process number has been passed to the receive call, 
     377      ! use that one. Default is to use mpi_any_source 
     378      use_source = mpi_any_source 
     379      IF( PRESENT(ksource) )   use_source = ksource 
     380      ! 
    285381      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
    286382#endif 
    287383      ! 
    288    END SUBROUTINE mpprecv 
     384   END SUBROUTINE mpprecv_dp 
     385 
     386 
     387   SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) 
     388      !!---------------------------------------------------------------------- 
     389      !!                  ***  routine mpprecv  *** 
     390      !! 
     391      !! ** Purpose :   Receive messag passing array 
     392      !! 
     393      !!---------------------------------------------------------------------- 
     394      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     395      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     396      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     397      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     398      !! 
     399      INTEGER :: istatus(mpi_status_size) 
     400      INTEGER :: iflag 
     401      INTEGER :: use_source 
     402      !!---------------------------------------------------------------------- 
     403      ! 
     404#if defined key_mpp_mpi 
     405      ! If a specific process number has been passed to the receive call, 
     406      ! use that one. Default is to use mpi_any_source 
     407      use_source = mpi_any_source 
     408      IF( PRESENT(ksource) )   use_source = ksource 
     409      ! 
     410      CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     411#endif 
     412      ! 
     413   END SUBROUTINE mpprecv_sp 
    289414 
    290415 
    … …  
    351476      CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    352477      CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    353       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
     478      COMPLEX(dp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    354479      REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    355480      LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    … …  
    359484      INTEGER ::   idvar 
    360485      INTEGER ::   ierr, ilocalcomm 
    361       COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
     486      COMPLEX(dp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    362487      !!---------------------------------------------------------------------- 
    363488#if defined key_mpp_mpi 
    … …  
    432557      INTEGER ::   idvar 
    433558      INTEGER ::   ierr, ilocalcomm 
    434       !!---------------------------------------------------------------------- 
    435 #if defined key_mpp_mpi 
     559      INTEGER ::   MPI_TYPE 
     560      !!---------------------------------------------------------------------- 
     561       
     562#if defined key_mpp_mpi 
     563      if( wp == dp ) then 
     564         MPI_TYPE = MPI_DOUBLE_PRECISION 
     565      else if ( wp == sp ) then 
     566         MPI_TYPE = MPI_REAL 
     567      else 
     568        CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) 
     569    
     570      end if 
     571 
    436572      ilocalcomm = mpi_comm_oce 
    437573      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    470606# if defined key_mpi2 
    471607      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    472       CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) 
    473       ndelayid(idvar) = 1 
     608      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    474609      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    475610# else 
    476       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     611      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    477612# endif 
    478613#else 
    … …  
    551686#  undef INTEGER_TYPE 
    552687! 
     688   !! 
     689   !!   ----   SINGLE PRECISION VERSIONS 
     690   !! 
     691#  define SINGLE_PRECISION 
    553692#  define REAL_TYPE 
    554693#  define DIM_0d 
    555 #     define ROUTINE_ALLREDUCE           mppmax_real 
     694#     define ROUTINE_ALLREDUCE           mppmax_real_sp 
    556695#     include "mpp_allreduce_generic.h90" 
    557696#     undef ROUTINE_ALLREDUCE 
    558697#  undef DIM_0d 
    559698#  define DIM_1d 
    560 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
     699#     define ROUTINE_ALLREDUCE           mppmax_a_real_sp 
     700#     include "mpp_allreduce_generic.h90" 
     701#     undef ROUTINE_ALLREDUCE 
     702#  undef DIM_1d 
     703#  undef SINGLE_PRECISION 
     704   !! 
     705   !! 
     706   !!   ----   DOUBLE PRECISION VERSIONS 
     707   !! 
     708! 
     709#  define DIM_0d 
     710#     define ROUTINE_ALLREDUCE           mppmax_real_dp 
     711#     include "mpp_allreduce_generic.h90" 
     712#     undef ROUTINE_ALLREDUCE 
     713#  undef DIM_0d 
     714#  define DIM_1d 
     715#     define ROUTINE_ALLREDUCE           mppmax_a_real_dp 
    561716#     include "mpp_allreduce_generic.h90" 
    562717#     undef ROUTINE_ALLREDUCE 
    … …  
    583738#  undef INTEGER_TYPE 
    584739! 
     740   !! 
     741   !!   ----   SINGLE PRECISION VERSIONS 
     742   !! 
     743#  define SINGLE_PRECISION 
    585744#  define REAL_TYPE 
    586745#  define DIM_0d 
    587 #     define ROUTINE_ALLREDUCE           mppmin_real 
     746#     define ROUTINE_ALLREDUCE           mppmin_real_sp 
    588747#     include "mpp_allreduce_generic.h90" 
    589748#     undef ROUTINE_ALLREDUCE 
    590749#  undef DIM_0d 
    591750#  define DIM_1d 
    592 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
     751#     define ROUTINE_ALLREDUCE           mppmin_a_real_sp 
     752#     include "mpp_allreduce_generic.h90" 
     753#     undef ROUTINE_ALLREDUCE 
     754#  undef DIM_1d 
     755#  undef SINGLE_PRECISION 
     756   !! 
     757   !!   ----   DOUBLE PRECISION VERSIONS 
     758   !! 
     759 
     760#  define DIM_0d 
     761#     define ROUTINE_ALLREDUCE           mppmin_real_dp 
     762#     include "mpp_allreduce_generic.h90" 
     763#     undef ROUTINE_ALLREDUCE 
     764#  undef DIM_0d 
     765#  define DIM_1d 
     766#     define ROUTINE_ALLREDUCE           mppmin_a_real_dp 
    593767#     include "mpp_allreduce_generic.h90" 
    594768#     undef ROUTINE_ALLREDUCE 
    … …  
    616790#  undef DIM_1d 
    617791#  undef INTEGER_TYPE 
    618 ! 
     792 
     793   !! 
     794   !!   ----   SINGLE PRECISION VERSIONS 
     795   !! 
     796#  define OPERATION_SUM 
     797#  define SINGLE_PRECISION 
    619798#  define REAL_TYPE 
    620799#  define DIM_0d 
    621 #     define ROUTINE_ALLREDUCE           mppsum_real 
     800#     define ROUTINE_ALLREDUCE           mppsum_real_sp 
    622801#     include "mpp_allreduce_generic.h90" 
    623802#     undef ROUTINE_ALLREDUCE 
    624803#  undef DIM_0d 
    625804#  define DIM_1d 
    626 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
     805#     define ROUTINE_ALLREDUCE           mppsum_a_real_sp 
     806#     include "mpp_allreduce_generic.h90" 
     807#     undef ROUTINE_ALLREDUCE 
     808#  undef DIM_1d 
     809#  undef REAL_TYPE 
     810#  undef OPERATION_SUM 
     811 
     812#  undef SINGLE_PRECISION 
     813 
     814   !! 
     815   !!   ----   DOUBLE PRECISION VERSIONS 
     816   !! 
     817#  define OPERATION_SUM 
     818#  define REAL_TYPE 
     819#  define DIM_0d 
     820#     define ROUTINE_ALLREDUCE           mppsum_real_dp 
     821#     include "mpp_allreduce_generic.h90" 
     822#     undef ROUTINE_ALLREDUCE 
     823#  undef DIM_0d 
     824#  define DIM_1d 
     825#     define ROUTINE_ALLREDUCE           mppsum_a_real_dp 
    627826#     include "mpp_allreduce_generic.h90" 
    628827#     undef ROUTINE_ALLREDUCE 
    … …  
    651850   !!---------------------------------------------------------------------- 
    652851   !! 
     852   !! 
     853   !!   ----   SINGLE PRECISION VERSIONS 
     854   !! 
     855#  define SINGLE_PRECISION 
    653856#  define OPERATION_MINLOC 
    654857#  define DIM_2d 
    655 #     define ROUTINE_LOC           mpp_minloc2d 
     858#     define ROUTINE_LOC           mpp_minloc2d_sp 
    656859#     include "mpp_loc_generic.h90" 
    657860#     undef ROUTINE_LOC 
    658861#  undef DIM_2d 
    659862#  define DIM_3d 
    660 #     define ROUTINE_LOC           mpp_minloc3d 
     863#     define ROUTINE_LOC           mpp_minloc3d_sp 
    661864#     include "mpp_loc_generic.h90" 
    662865#     undef ROUTINE_LOC 
    … …  
    666869#  define OPERATION_MAXLOC 
    667870#  define DIM_2d 
    668 #     define ROUTINE_LOC           mpp_maxloc2d 
     871#     define ROUTINE_LOC           mpp_maxloc2d_sp 
    669872#     include "mpp_loc_generic.h90" 
    670873#     undef ROUTINE_LOC 
    671874#  undef DIM_2d 
    672875#  define DIM_3d 
    673 #     define ROUTINE_LOC           mpp_maxloc3d 
     876#     define ROUTINE_LOC           mpp_maxloc3d_sp 
    674877#     include "mpp_loc_generic.h90" 
    675878#     undef ROUTINE_LOC 
    676879#  undef DIM_3d 
    677880#  undef OPERATION_MAXLOC 
     881#  undef SINGLE_PRECISION 
     882   !! 
     883   !!   ----   DOUBLE PRECISION VERSIONS 
     884   !! 
     885#  define OPERATION_MINLOC 
     886#  define DIM_2d 
     887#     define ROUTINE_LOC           mpp_minloc2d_dp 
     888#     include "mpp_loc_generic.h90" 
     889#     undef ROUTINE_LOC 
     890#  undef DIM_2d 
     891#  define DIM_3d 
     892#     define ROUTINE_LOC           mpp_minloc3d_dp 
     893#     include "mpp_loc_generic.h90" 
     894#     undef ROUTINE_LOC 
     895#  undef DIM_3d 
     896#  undef OPERATION_MINLOC 
     897 
     898#  define OPERATION_MAXLOC 
     899#  define DIM_2d 
     900#     define ROUTINE_LOC           mpp_maxloc2d_dp 
     901#     include "mpp_loc_generic.h90" 
     902#     undef ROUTINE_LOC 
     903#  undef DIM_2d 
     904#  define DIM_3d 
     905#     define ROUTINE_LOC           mpp_maxloc3d_dp 
     906#     include "mpp_loc_generic.h90" 
     907#     undef ROUTINE_LOC 
     908#  undef DIM_3d 
     909#  undef OPERATION_MAXLOC 
     910 
    678911 
    679912   SUBROUTINE mppsync() 
    … …  
    9041137      !!--------------------------------------------------------------------- 
    9051138      INTEGER                     , INTENT(in)    ::   ilen, itype 
    906       COMPLEX(wp), DIMENSION(ilen), INTENT(in)    ::   ydda 
    907       COMPLEX(wp), DIMENSION(ilen), INTENT(inout) ::   yddb 
    908       ! 
    909       REAL(wp) :: zerr, zt1, zt2    ! local work variables 
     1139      COMPLEX(dp), DIMENSION(ilen), INTENT(in)    ::   ydda 
     1140      COMPLEX(dp), DIMENSION(ilen), INTENT(inout) ::   yddb 
     1141      ! 
     1142      REAL(dp) :: zerr, zt1, zt2    ! local work variables 
    9101143      INTEGER  :: ji, ztmp           ! local scalar 
    9111144      !!--------------------------------------------------------------------- 
    … …  
    10601293    LOGICAL,           INTENT(IN) :: ld_tic 
    10611294    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 
    1062     REAL(wp), DIMENSION(2), SAVE :: tic_wt 
    1063     REAL(wp),               SAVE :: tic_ct = 0._wp 
     1295    REAL(dp), DIMENSION(2), SAVE :: tic_wt 
     1296    REAL(dp),               SAVE :: tic_ct = 0._dp 
    10641297    INTEGER :: ii 
    10651298#if defined key_mpp_mpi 
    … …  
    10741307    IF ( ld_tic ) THEN 
    10751308       tic_wt(ii) = MPI_Wtime()                                                    ! start count tic->tac (waiting time) 
    1076        IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
     1309       IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
    10771310    ELSE 
    10781311       waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii)              ! cumulate count tic->tac 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/mpp_allreduce_generic.h90

    r10425 r13228  
    11!                          !==  IN: ptab is an array  ==! 
    22#   if defined REAL_TYPE 
    3 #      define ARRAY_TYPE(i)    REAL(wp)         , INTENT(inout) ::   ARRAY_IN(i) 
    4 #      define TMP_TYPE(i)      REAL(wp)         , ALLOCATABLE   ::   work(i) 
    5 #      define MPI_TYPE mpi_double_precision 
     3#      if defined SINGLE_PRECISION 
     4#         define ARRAY_TYPE(i)    REAL(sp)         , INTENT(inout) ::   ARRAY_IN(i) 
     5#         define TMP_TYPE(i)      REAL(sp)         , ALLOCATABLE   ::   work(i) 
     6#         define MPI_TYPE mpi_real 
     7#      else 
     8#         define ARRAY_TYPE(i)    REAL(dp)         , INTENT(inout) ::   ARRAY_IN(i) 
     9#         define TMP_TYPE(i)      REAL(dp)         , ALLOCATABLE   ::   work(i) 
     10#         define MPI_TYPE mpi_double_precision 
     11#      endif  
    612#   endif 
    713#   if defined INTEGER_TYPE 
    … …  
    1117#   endif 
    1218#   if defined COMPLEX_TYPE 
    13 #      define ARRAY_TYPE(i)    COMPLEX          , INTENT(inout) ::   ARRAY_IN(i) 
    14 #      define TMP_TYPE(i)      COMPLEX          , ALLOCATABLE   ::   work(i) 
     19#      define ARRAY_TYPE(i)    COMPLEX(dp)       , INTENT(inout) ::   ARRAY_IN(i) 
     20#      define TMP_TYPE(i)      COMPLEX(dp)       , ALLOCATABLE   ::   work(i) 
    1521#      define MPI_TYPE mpi_double_complex 
    1622#   endif 
    … …  
    7581   END SUBROUTINE ROUTINE_ALLREDUCE 
    7682 
     83#undef PRECISION 
    7784#undef ARRAY_TYPE 
    7885#undef ARRAY_IN 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/mpp_lnk_generic.h90

    r11536 r13228  
    55#   define OPT_K(k)                 ,ipf 
    66#   if defined DIM_2d 
    7 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)                , INTENT(inout) ::   ptab(f) 
     7#      if defined SINGLE_PRECISION 
     8#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp)                , INTENT(inout) ::   ptab(f) 
     9#      else 
     10#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp)                , INTENT(inout) ::   ptab(f) 
     11#      endif 
    812#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    913#      define K_SIZE(ptab)             1 
    … …  
    1115#   endif 
    1216#   if defined DIM_3d 
    13 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)                , INTENT(inout) ::   ptab(f) 
     17#      if defined SINGLE_PRECISION 
     18#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp)                , INTENT(inout) ::   ptab(f) 
     19#      else 
     20#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp)                , INTENT(inout) ::   ptab(f) 
     21#      endif 
    1422#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1523#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1725#   endif 
    1826#   if defined DIM_4d 
    19 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)                , INTENT(inout) ::   ptab(f) 
     27#      if defined SINGLE_PRECISION 
     28#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp)                , INTENT(inout) ::   ptab(f) 
     29#      else 
     30#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp)                , INTENT(inout) ::   ptab(f) 
     31#      endif 
    2032#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2133#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    … …  
    2335#   endif 
    2436#else 
    25 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     37#   if defined SINGLE_PRECISION 
     38#      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     39#   else 
     40#      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     41#   endif 
    2642#   define NAT_IN(k)                cd_nat 
    2743#   define SGN_IN(k)                psgn 
    … …  
    4460#   endif 
    4561#endif 
     62 
     63# if defined SINGLE_PRECISION 
     64#    define PRECISION sp 
     65#    define SENDROUTINE mppsend_sp 
     66#    define RECVROUTINE mpprecv_sp 
     67# else 
     68#    define PRECISION dp 
     69#    define SENDROUTINE mppsend_dp 
     70#    define RECVROUTINE mpprecv_dp 
     71# endif 
    4672 
    4773#if defined MULTI 
    … …  
    6793      INTEGER  ::   ifill_we, ifill_ea, ifill_so, ifill_no 
    6894      INTEGER  ::   ihl                          ! number of ranks and rows to be communicated  
    69       REAL(wp) ::   zland 
     95      REAL(PRECISION) ::   zland 
    7096      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   istat          ! for mpi_isend 
    71       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos 
    72       REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos 
     97      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos 
     98      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos 
    7399      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send 
    74100      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive  
    … …  
    174200      ! 
    175201      ! non-blocking send of the western/eastern side using local temporary arrays 
    176       IF( llsend_we )   CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 
    177       IF( llsend_ea )   CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 
     202      IF( llsend_we )   CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 
     203      IF( llsend_ea )   CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 
    178204      ! blocking receive of the western/eastern halo in local temporary arrays 
    179       IF( llrecv_we )   CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 
    180       IF( llrecv_ea )   CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 
     205      IF( llrecv_we )   CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 
     206      IF( llrecv_ea )   CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 
    181207      ! 
    182208      IF( ln_timing ) CALL tic_tac(.FALSE.) 
    … …  
    289315      ! 
    290316      ! non-blocking send of the southern/northern side 
    291       IF( llsend_so )   CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 
    292       IF( llsend_no )   CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 
     317      IF( llsend_so )   CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 
     318      IF( llsend_no )   CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 
    293319      ! blocking receive of the southern/northern halo 
    294       IF( llrecv_so )   CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 
    295       IF( llrecv_no )   CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 
     320      IF( llrecv_so )   CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso ) 
     321      IF( llrecv_no )   CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono ) 
    296322      ! 
    297323      IF( ln_timing ) CALL tic_tac(.FALSE.) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/mpp_loc_generic.h90

    r13193 r13228  
    11                          !==  IN: ptab is an array  ==! 
    2 #      define ARRAY_TYPE(i,j,k)    REAL(wp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
    3 #      define MASK_TYPE(i,j,k)     REAL(wp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     2#   if defined SINGLE_PRECISION 
     3#      define ARRAY_TYPE(i,j,k)    REAL(sp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
     4#      define MASK_TYPE(i,j,k)     REAL(sp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     5#      define PRECISION sp 
     6#   else 
     7#      define ARRAY_TYPE(i,j,k)    REAL(dp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
     8#      define MASK_TYPE(i,j,k)     REAL(dp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     9#      define PRECISION dp 
     10#   endif 
     11 
    412#   if defined DIM_2d 
    513#      define ARRAY_IN(i,j,k)   ptab(i,j) 
    … …  
    3038      ARRAY_TYPE(:,:,:)                            ! array on which loctrans operation is applied 
    3139      MASK_TYPE(:,:,:)                             ! local mask 
    32       REAL(wp)        , INTENT(  out) ::   pmin    ! Global minimum of ptab 
     40      REAL(PRECISION)        , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    3341      INDEX_TYPE(:)                                ! index of minimum in global frame 
    3442      ! 
    3543      INTEGER  ::   ierror, ii, idim 
    3644      INTEGER  ::   index0 
    37       REAL(wp) ::   zmin     ! local minimum 
     45      REAL(PRECISION) ::   zmin     ! local minimum 
    3846      INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs 
    39       REAL(wp), DIMENSION(2,1) ::   zain, zaout 
     47      REAL(dp), DIMENSION(2,1) ::   zain, zaout 
    4048      !!----------------------------------------------------------------------- 
    4149      ! 
    … …  
    98106   END SUBROUTINE ROUTINE_LOC 
    99107 
     108 
     109#undef PRECISION 
    100110#undef ARRAY_TYPE 
    101111#undef MAX_TYPE 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/mpp_nfd_generic.h90

    r11536 r13228  
    55#   define LBC_ARG                  (jf) 
    66#   if defined DIM_2d 
    7 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)     , INTENT(inout) ::   ptab(f) 
     7#      if defined SINGLE_PRECISION 
     8#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp)     , INTENT(inout) ::   ptab(f) 
     9#      else 
     10#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp)     , INTENT(inout) ::   ptab(f) 
     11#      endif 
    812#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    913#      define K_SIZE(ptab)             1 
    … …  
    1115#   endif 
    1216#   if defined DIM_3d 
    13 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)     , INTENT(inout) ::   ptab(f) 
     17#      if defined SINGLE_PRECISION 
     18#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp)     , INTENT(inout) ::   ptab(f) 
     19#      else 
     20#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp)     , INTENT(inout) ::   ptab(f) 
     21#      endif 
    1422#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    1523#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    … …  
    1725#   endif 
    1826#   if defined DIM_4d 
    19 #      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)     , INTENT(inout) ::   ptab(f) 
     27#      if defined SINGLE_PRECISION 
     28#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp)     , INTENT(inout) ::   ptab(f) 
     29#      else 
     30#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp)     , INTENT(inout) ::   ptab(f) 
     31#      endif 
    2032#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    2133#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    … …  
    2436#else 
    2537!                          !==  IN: ptab is an array  ==! 
    26 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     38#   if defined SINGLE_PRECISION 
     39#      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     40#   else 
     41#      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
     42#   endif 
    2743#   define NAT_IN(k)                cd_nat 
    2844#   define SGN_IN(k)                psgn 
    … …  
    4561#   endif 
    4662#endif 
     63 
     64# if defined SINGLE_PRECISION 
     65#    define PRECISION sp 
     66#    define SENDROUTINE mppsend_sp 
     67#    define RECVROUTINE mpprecv_sp 
     68#    define MPI_TYPE MPI_REAL 
     69# else 
     70#    define PRECISION dp 
     71#    define SENDROUTINE mppsend_dp 
     72#    define RECVROUTINE mpprecv_dp 
     73#    define MPI_TYPE MPI_DOUBLE_PRECISION 
     74# endif 
    4775 
    4876   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 
    … …  
    6694      INTEGER, DIMENSION(:,:),          ALLOCATABLE ::   jj_s  ! position of sent lines 
    6795      INTEGER, DIMENSION(:),            ALLOCATABLE ::   ipj_s ! number of sent lines 
    68       REAL(wp), DIMENSION(:,:,:)      , ALLOCATABLE ::   ztabl 
    69       REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabr 
    70       REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk       
    71       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio 
     96      REAL(PRECISION), DIMENSION(:,:,:)      , ALLOCATABLE ::   ztabl 
     97      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabr 
     98      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk       
     99      REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio 
    72100      !!---------------------------------------------------------------------- 
    73101      ! 
    … …  
    160188         DO jr = 1, nsndto 
    161189            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    162                CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
     190               CALL SENDROUTINE( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    163191            ENDIF 
    164192         END DO 
    … …  
    176204            ENDIF 
    177205            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    178                CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 
     206               CALL RECVROUTINE(5, zfoldwk, ibuffsize, iproc) 
    179207               js = 0 
    180208               DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
    … …  
    246274         ! start waiting time measurement 
    247275         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    248          CALL MPI_ALLGATHER( znorthloc  , ibuffsize, MPI_DOUBLE_PRECISION,                & 
    249             &                znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     276         CALL MPI_ALLGATHER( znorthloc  , ibuffsize, MPI_TYPE,                & 
     277            &                znorthgloio, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 
    250278         ! 
    251279         ! stop waiting time measurement 
    … …  
    298326   END SUBROUTINE ROUTINE_NFD 
    299327 
     328#undef PRECISION 
     329#undef MPI_TYPE 
     330#undef SENDROUTINE 
     331#undef RECVROUTINE 
    300332#undef ARRAY_TYPE 
    301333#undef NAT_IN 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LDF/ldfc1d_c2d.F90

    r12377 r13228  
    8585            pah2(ji,jj,jk) = pahs2(ji,jj) * (  zratio + zc * ( 1._wp + TANH( - ( zdep2 - zh ) * zw) )  ) 
    8686         END_3D 
    87          CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1. )   ! Lateral boundary conditions 
     87         CALL lbc_lnk( 'ldfc1d_c2d', pah2, 'F', 1.0_wp )   ! Lateral boundary conditions 
    8888         ! 
    8989      CASE( 'TRA' )                     ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.) 
    … …  
    9595         END_3D 
    9696         ! Lateral boundary conditions 
    97          CALL lbc_lnk_multi( 'ldfc1d_c2d', pah1, 'U', 1. , pah2, 'V', 1. )    
     97         CALL lbc_lnk_multi( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp )    
    9898         ! 
    9999      CASE DEFAULT                        ! error 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LDF/ldfdyn.F90

    r12724 r13228  
    398398         ENDIF 
    399399         ! 
    400          CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.,  ahmf, 'F', 1. ) 
     400         CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp,  ahmf, 'F', 1.0_wp ) 
    401401         ! 
    402402         ! 
    … …  
    430430            END DO 
    431431            ! 
    432             CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1. )  ! lbc_lnk on dshesq not needed 
     432            CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1.0_wp )  ! lbc_lnk on dshesq not needed 
    433433            ! 
    434434            DO jk = 1, jpkm1 
    … …  
    481481         ENDIF 
    482482         ! 
    483          CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1. , ahmf, 'F', 1. ) 
     483         CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) 
    484484         ! 
    485485      END SELECT 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LDF/ldfslp.F90

    r12731 r13228  
    229229!!gm end modif 
    230230      END_3D 
    231       CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.,  zww, 'V', -1. )      ! lateral boundary conditions 
     231      CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp,  zww, 'V', -1.0_wp )      ! lateral boundary conditions 
    232232      ! 
    233233      !                                            !* horizontal Shapiro filter 
    … …  
    303303!!gm end modif 
    304304      END_3D 
    305       CALL lbc_lnk_multi( 'ldfslp', zwz, 'T', -1.,  zww, 'T', -1. )      ! lateral boundary conditions 
     305      CALL lbc_lnk_multi( 'ldfslp', zwz, 'T', -1.0_wp,  zww, 'T', -1.0_wp )      ! lateral boundary conditions 
    306306      ! 
    307307      !                                           !* horizontal Shapiro filter 
    … …  
    348348      ! IV. Lateral boundary conditions 
    349349      ! =============================== 
    350       CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1. , vslp , 'V', -1. , wslpi, 'W', -1., wslpj, 'W', -1. ) 
     350      CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 
    351351 
    352352      IF(sn_cfctl%l_prtctl) THEN 
    … …  
    580580      wslp2(:,:,1) = 0._wp                ! force the surface wslp to zero 
    581581 
    582       CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1. )      ! lateral boundary confition on wslp2 only   ==>>> gm : necessary ? to be checked 
     582      CALL lbc_lnk( 'ldfslp', wslp2, 'W', 1.0_wp )      ! lateral boundary confition on wslp2 only   ==>>> gm : necessary ? to be checked 
    583583      ! 
    584584      IF( ln_timing )   CALL timing_stop('ldf_slp_triad') 
    … …  
    689689      END_2D 
    690690      !!gm this lbc_lnk should be useless.... 
    691       CALL lbc_lnk_multi( 'ldfslp', uslpml , 'U', -1. , vslpml , 'V', -1. , wslpiml, 'W', -1. , wslpjml, 'W', -1. )  
     691      CALL lbc_lnk_multi( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp )  
    692692      ! 
    693693   END SUBROUTINE ldf_slp_mxl 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LDF/ldftra.F90

    r12724 r13228  
    692692         zaeiw(ji,jj) = MIN( zzaei , paei0 )                                  ! Max value = paei0 
    693693      END_2D 
    694       CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1. )       ! lateral boundary condition 
     694      CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp )       ! lateral boundary condition 
    695695      !                
    696696      DO_2D_00_00 
    … …  
    698698         paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji  ,jj+1) ) * vmask(ji,jj,1) 
    699699      END_2D 
    700       CALL lbc_lnk_multi( 'ldftra', paeiu(:,:,1), 'U', 1. , paeiv(:,:,1), 'V', 1. )      ! lateral boundary condition 
     700      CALL lbc_lnk_multi( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp )      ! lateral boundary condition 
    701701 
    702702      DO jk = 2, jpkm1                          !==  deeper values equal the surface one  ==! 
    … …  
    794794!!gm     to be redesigned....    
    795795      !                                                  !==  eiv stream function: output  ==! 
    796       CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1. , psi_vw, 'V', -1. ) 
     796      CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1.0_wp , psi_vw, 'V', -1.0_wp ) 
    797797      ! 
    798798!!gm      CALL iom_put( "psi_eiv_uw", psi_uw )                 ! output 
    … …  
    817817            &              + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj  ,jk)  ) / e1e2t(ji,jj) 
    818818      END_3D 
    819       CALL lbc_lnk( 'ldftra', zw3d, 'T', 1. )      ! lateral boundary condition 
     819      CALL lbc_lnk( 'ldftra', zw3d, 'T', 1.0_wp )      ! lateral boundary condition 
    820820      CALL iom_put( "woce_eiv", zw3d ) 
    821821      ! 
    … …  
    845845           zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    846846        END_3D 
    847         CALL lbc_lnk( 'ldftra', zw2d, 'U', -1. ) 
    848         CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. ) 
     847        CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 
     848        CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 
    849849        CALL iom_put( "ueiv_heattr"  , zztmp * zw2d )                  ! heat transport in i-direction 
    850850        CALL iom_put( "ueiv_heattr3d", zztmp * zw3d )                  ! heat transport in i-direction 
    … …  
    866866         zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    867867      END_3D 
    868       CALL lbc_lnk( 'ldftra', zw2d, 'V', -1. ) 
     868      CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 
    869869      CALL iom_put( "veiv_heattr", zztmp * zw2d )                  !  heat transport in j-direction 
    870870      CALL iom_put( "veiv_heattr", zztmp * zw3d )                  !  heat transport in j-direction 
    … …  
    881881           zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    882882        END_3D 
    883         CALL lbc_lnk( 'ldftra', zw2d, 'U', -1. ) 
    884         CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. ) 
     883        CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 
     884        CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 
    885885        CALL iom_put( "ueiv_salttr", zztmp * zw2d )                  ! salt transport in i-direction 
    886886        CALL iom_put( "ueiv_salttr3d", zztmp * zw3d )                ! salt transport in i-direction 
    … …  
    893893         zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    894894      END_3D 
    895       CALL lbc_lnk( 'ldftra', zw2d, 'V', -1. ) 
     895      CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 
    896896      CALL iom_put( "veiv_salttr", zztmp * zw2d )                  !  salt transport in j-direction 
    897897      CALL iom_put( "veiv_salttr", zztmp * zw3d )                  !  salt transport in j-direction 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/OBS/ddatetoymdhms.h90

    r10068 r13228  
    2121 
    2222      !! * Arguments 
    23       real(wp), INTENT(IN) :: ddate 
     23      real(dp), INTENT(IN) :: ddate 
    2424      INTEGER, INTENT(OUT) :: kyea 
    2525      INTEGER, INTENT(OUT) :: kmon 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/OBS/grt_cir_dis.h90

    r10068 r13228  
    2828      REAL(KIND=wp) :: pc2   !  cos(lat2) * sin(lon2) 
    2929 
     30      REAL(KIND=wp) :: cosdist ! cosine of great circle distance 
     31 
     32      ! Compute cosine of great circle distance, constraining it to be between 
     33      ! -1 and 1 (rounding errors can take it slightly outside this range 
     34      cosdist = MAX( MIN( pa1 * pa2 + pb1 * pb2 + pc1 * pc2, 1.0_wp), -1.0_wp ) 
     35 
    3036      grt_cir_dis = & 
    31          &  ASIN( SQRT( 1.0 - ( pa1 * pa2 + pb1 * pb2 + pc1 * pc2 )**2 ) ) 
     37         &  ASIN( SQRT( 1.0_wp - cosdist**2.0_wp ) ) 
    3238       
    3339   END FUNCTION grt_cir_dis 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/OBS/obs_read_prof.F90

    r10068 r13228  
    140140         & zphi, & 
    141141         & zlam 
    142       REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
     142      REAL(dp), DIMENSION(:), ALLOCATABLE :: & 
    143143         & zdat 
    144       REAL(wp), DIMENSION(knumfiles) :: & 
     144      REAL(dp), DIMENSION(knumfiles) :: & 
    145145         & djulini, & 
    146146         & djulend 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/OBS/obs_read_surf.F90

    r10069 r13228  
    112112         & zphi, & 
    113113         & zlam 
    114       REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
     114      REAL(dp), DIMENSION(:), ALLOCATABLE :: & 
    115115         & zdat 
    116       REAL(wp), DIMENSION(knumfiles) :: & 
     116      REAL(dp), DIMENSION(knumfiles) :: & 
    117117         & djulini, & 
    118118         & djulend 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/OBS/obsinter_z1d.h90

    r10068 r13228  
    6262         z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep)      ) 
    6363         z1dp = ( pobsdep(jdep)    - pdep(kkco(jdep)-1) ) 
    64          IF ( pobsmask(kkco(jdep)) == 0.0_wp ) z1dp = 0.0_wp 
     64          
     65         ! If kkco(jdep) is masked then set pobs(jdep) to the lowest value located above bathymetry 
     66         IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN 
     67            pobs(jdep) = pobsk(kkco(jdep)-1) 
     68         ELSE 
     69            zsum = z1dm + z1dp 
    6570 
    66          zsum = z1dm + z1dp 
    67           
    68          IF ( k1dint == 0 ) THEN 
     71            IF ( k1dint == 0 ) THEN 
    6972 
    70             !----------------------------------------------------------------- 
    71             !  Linear interpolation 
    72             !----------------------------------------------------------------- 
    73             pobs(jdep) = (   z1dm * pobsk(kkco(jdep)-1) & 
    74                &           + z1dp * pobsk(kkco(jdep)  ) ) / zsum 
     73               !----------------------------------------------------------------- 
     74               !  Linear interpolation 
     75               !----------------------------------------------------------------- 
     76               pobs(jdep) = (   z1dm * pobsk(kkco(jdep)-1) & 
     77                  &           + z1dp * pobsk(kkco(jdep)  ) ) / zsum 
    7578 
    76          ELSEIF ( k1dint == 1 ) THEN 
     79            ELSEIF ( k1dint == 1 ) THEN 
    7780 
    78             !----------------------------------------------------------------- 
    79             ! Cubic spline interpolation 
    80             !----------------------------------------------------------------- 
    81             zsum2 = zsum * zsum 
    82             pobs(jdep)  = (  z1dm                             * pobsk (kkco(jdep)-1) & 
    83                &           + z1dp                             * pobsk (kkco(jdep)  ) & 
    84                &           + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & 
    85                &           +   z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep)  ) & 
    86                &             ) / 6.0_wp                                              & 
    87                &          ) / zsum 
     81               !----------------------------------------------------------------- 
     82               ! Cubic spline interpolation 
     83               !----------------------------------------------------------------- 
     84               zsum2 = zsum * zsum 
     85               pobs(jdep)  = (  z1dm                             * pobsk (kkco(jdep)-1) & 
     86                  &           + z1dp                             * pobsk (kkco(jdep)  ) & 
     87                  &           + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & 
     88                  &           +   z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep)  ) & 
     89                  &             ) / 6.0_wp                                              & 
     90                  &          ) / zsum 
    8891 
     92            ENDIF 
    8993         ENDIF 
    9094      END DO 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/fldread.F90

    r12724 r13228  
    384384               IF( sdjf%ln_tint ) THEN 
    385385                  CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fdta(2,2,1,2), sdjf%nrec_a(1) ) 
    386                   CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,1,2),'Z',1. ) 
     386                  CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,1,2),'Z',1.0_wp ) 
    387387               ELSE 
    388388                  CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fnow(2,2,1  ), sdjf%nrec_a(1) ) 
    389                   CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,1  ),'Z',1. ) 
     389                  CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,1  ),'Z',1.0_wp ) 
    390390               ENDIF 
    391391            ELSE 
    … …  
    398398               IF( sdjf%ln_tint ) THEN 
    399399                  CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fdta(2,2,:,2), sdjf%nrec_a(1) ) 
    400                   CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,:,2),'Z',1. ) 
     400                  CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,:,2),'Z',1.0_wp ) 
    401401               ELSE 
    402402                  CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fnow(2,2,:  ), sdjf%nrec_a(1) ) 
    403                   CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,:  ),'Z',1. ) 
     403                  CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,:  ),'Z',1.0_wp ) 
    404404               ENDIF 
    405405            ELSE 
    … …  
    13271327      !!      D. Delrosso INGV 
    13281328      !!----------------------------------------------------------------------  
    1329       INTEGER                      , INTENT(in   ) :: ileni,ilenj   ! lengths  
    1330       REAL, DIMENSION (ileni,ilenj), INTENT(in   ) :: zfieldn       ! array of forcing field with undeff for land points 
    1331       REAL, DIMENSION (ileni,ilenj), INTENT(  out) :: zfield        ! array of forcing field 
    1332       ! 
    1333       REAL  , DIMENSION (ileni,ilenj)   :: zmat1, zmat2, zmat3, zmat4  ! local arrays  
    1334       REAL  , DIMENSION (ileni,ilenj)   :: zmat5, zmat6, zmat7, zmat8  !   -     -  
    1335       REAL  , DIMENSION (ileni,ilenj)   :: zlsm2d                      !   -     -  
    1336       REAL  , DIMENSION (ileni,ilenj,8) :: zlsm3d                      !   -     - 
    1337       LOGICAL, DIMENSION (ileni,ilenj,8) :: ll_msknan3d                 ! logical mask for undeff detection 
    1338       LOGICAL, DIMENSION (ileni,ilenj)   :: ll_msknan2d                 ! logical mask for undeff detection 
     1329      INTEGER                          , INTENT(in   ) :: ileni,ilenj   ! lengths  
     1330      REAL(wp), DIMENSION (ileni,ilenj), INTENT(in   ) :: zfieldn       ! array of forcing field with undeff for land points 
     1331      REAL(wp), DIMENSION (ileni,ilenj), INTENT(  out) :: zfield        ! array of forcing field 
     1332      ! 
     1333      REAL(wp) , DIMENSION (ileni,ilenj)   :: zmat1, zmat2, zmat3, zmat4  ! local arrays  
     1334      REAL(wp) , DIMENSION (ileni,ilenj)   :: zmat5, zmat6, zmat7, zmat8  !   -     -  
     1335      REAL(wp) , DIMENSION (ileni,ilenj)   :: zlsm2d                      !   -     -  
     1336      REAL(wp) , DIMENSION (ileni,ilenj,8) :: zlsm3d                      !   -     - 
     1337      LOGICAL  , DIMENSION (ileni,ilenj,8) :: ll_msknan3d                 ! logical mask for undeff detection 
     1338      LOGICAL  , DIMENSION (ileni,ilenj)   :: ll_msknan2d                 ! logical mask for undeff detection 
    13391339      !!----------------------------------------------------------------------  
    13401340      zmat8 = eoshift( zfieldn , SHIFT=-1 , BOUNDARY = (/zfieldn(:,1)/)     , DIM=2 ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/geo2ocean.F90

    r12377 r13228  
    272272      ! =========================== ! 
    273273      !           ! lateral boundary cond.: T-, U-, V-, F-pts, sgn 
    274       CALL lbc_lnk_multi( 'geo2ocean', gcost, 'T', -1., gsint, 'T', -1., gcosu, 'U', -1., gsinu, 'U', -1., &  
    275                       &   gcosv, 'V', -1., gsinv, 'V', -1., gcosf, 'F', -1., gsinf, 'F', -1.  ) 
     274      CALL lbc_lnk_multi( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, &  
     275                      &   gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp  ) 
    276276      ! 
    277277   END SUBROUTINE angle 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbc_oce.F90

    r12377 r13228  
    223223         wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) 
    224224      END_2D 
    225       CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1. ) 
     225      CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1.0_wp ) 
    226226      ! 
    227227   END SUBROUTINE sbc_tau2wnd 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbcblk.F90

    r13217 r13228  
    971971            pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji  ,jj+1) ) 
    972972         END_2D 
    973          CALL lbc_lnk_multi( 'sbcblk', putaui, 'U', -1., pvtaui, 'V', -1. ) 
     973         CALL lbc_lnk_multi( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) 
    974974         ! 
    975975         IF(sn_cfctl%l_prtctl)  CALL prt_ctl( tab2d_1=putaui  , clinfo1=' blk_ice: putaui : '   & 
    … …  
    14391439         ! 
    14401440      END_2D 
    1441       CALL lbc_lnk_multi( 'sbcblk', pcd, 'T',  1., pch, 'T', 1. ) 
     1441      CALL lbc_lnk_multi( 'sbcblk', pcd, 'T',  1.0_wp, pch, 'T', 1.0_wp ) 
    14421442      ! 
    14431443   END SUBROUTINE Cdn10_Lupkes2015 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbccpl.F90

    r13193 r13228  
    11741174                  frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji  ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 
    11751175               END_2D 
    1176                CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U',  -1., frcv(jpr_oty1)%z3(:,:,1), 'V',  -1. ) 
     1176               CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U',  -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V',  -1.0_wp ) 
    11771177            ENDIF 
    11781178            llnewtx = .TRUE. 
    … …  
    11991199               frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) 
    12001200            END_2D 
    1201             CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1. ) 
     1201            CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1.0_wp ) 
    12021202            llnewtau = .TRUE. 
    12031203         ELSE 
    … …  
    23762376                  zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  )     + v_ice(ji  ,jj-1  )     ) *  fr_i(ji,jj) 
    23772377               END_2D 
    2378                CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. ) 
     2378               CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 
    23792379            CASE( 'mixed oce-ice'        )      ! Ocean and Ice on C-grid ==> T 
    23802380               DO_2D_00_00 
    … …  
    23852385               END_2D 
    23862386            END SELECT 
    2387             CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.,  zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 
     2387            CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp,  zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) 
    23882388            ! 
    23892389         ENDIF 
    … …  
    24532453                zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj)  
    24542454             END_2D 
    2455              CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.,  zity1, 'T', -1. )  
     2455             CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp,  zity1, 'T', -1.0_wp )  
    24562456          CASE( 'mixed oce-ice'        )      ! Ocean and Ice on C-grid ==> T   
    24572457             DO_2D_00_00 
    … …  
    24622462             END_2D 
    24632463          END SELECT 
    2464          CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1., zoty1, ssnd(jps_ocyw)%clgrid, -1. )  
     2464         CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp )  
    24652465         !  
    24662466         !  

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbcflx.F90

    r12377 r13228  
    151151         END_2D 
    152152         taum(:,:) = taum(:,:) * tmask(:,:,1) ; wndm(:,:) = wndm(:,:) * tmask(:,:,1) 
    153          CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1. )   ;   CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1. ) 
     153         CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1.0_wp )   ;   CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1.0_wp ) 
    154154 
    155155         IF( nitend-nit000 <= 100 .AND. lwp ) THEN                ! control print (if less than 100 time-step asked) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbcfwb.F90

    r12724 r13228  
    7171      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   ztmsk_tospread, zerp_cor    !   -      - 
    7272      REAL(wp)   ,DIMENSION(1) ::   z_fwfprv   
    73       COMPLEX(wp),DIMENSION(1) ::   y_fwfnow   
     73      COMPLEX(dp),DIMENSION(1) ::   y_fwfnow   
    7474      !!---------------------------------------------------------------------- 
    7575      ! 
    … …  
    180180            ! 
    181181!!gm   ===>>>>  lbc_lnk should be useless as all the computation is done over the whole domain ! 
    182             CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1. ) 
     182            CALL lbc_lnk( 'sbcfwb', zerp_cor, 'T', 1.0_wp ) 
    183183            ! 
    184184            emp(:,:) = emp(:,:) + zerp_cor(:,:) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbcice_cice.F90

    r12732 r13228  
    222222      END_2D 
    223223 
    224       CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.,  fr_iv , 'V', 1. ) 
     224      CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp,  fr_iv , 'V', 1.0_wp ) 
    225225 
    226226      ! set the snow+ice mass 
    … …  
    506506         ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1) 
    507507      END_2D 
    508       CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1. ) 
     508      CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1.0_wp ) 
    509509 
    510510! y comp of ocean-ice stress 
    … …  
    516516         ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1) 
    517517      END_2D 
    518       CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1. ) 
     518      CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1.0_wp ) 
    519519 
    520520! x and y comps of surface stress 
    … …  
    569569      fmmflx(:,:) = ztmp1(:,:) !!Joakim edit 
    570570 
    571       CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1., sfx , 'T', 1. ) 
     571      CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp ) 
    572572 
    573573! Solar penetrative radiation and non solar surface heat flux 
    … …  
    595595#endif 
    596596      qsr(:,:)=qsr(:,:)+ztmp1(:,:) 
    597       CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1. ) 
     597      CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1.0_wp ) 
    598598 
    599599      DO_2D_11_11 
    … …  
    608608      qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:) 
    609609 
    610       CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1. ) 
     610      CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1.0_wp ) 
    611611 
    612612! Prepare for the following CICE time-step 
    … …  
    626626      END_2D 
    627627 
    628       CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1., fr_iv , 'V', 1. ) 
     628      CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) 
    629629 
    630630      ! set the snow+ice mass 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbcmod.F90

    r13219 r13228  
    461461         ! A lbc_lnk is therefore needed to ensure reproducibility and restartability. 
    462462         ! see ticket #2113 for discussion about this lbc_lnk. 
    463          IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1. ) ! ensure restartability with icebergs 
     463         IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) ! ensure restartability with icebergs 
    464464      ENDIF 
    465465 
    … …  
    476476!!$!RBbug do not understand why see ticket 667 
    477477!!$!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. 
    478 !!$      CALL lbc_lnk( 'sbcmod', emp, 'T', 1. ) 
     478!!$      CALL lbc_lnk( 'sbcmod', emp, 'T', 1.0_wp ) 
    479479      IF( ll_wd ) THEN     ! If near WAD point limit the flux for now 
    480480         zthscl = atanh(rn_wd_sbcfra)                     ! taper frac default is .999  

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbcssr.F90

    r12377 r13228  
    131131                     &        * ( sss_m(ji,jj) - sf_sss(1)%fnow(ji,jj,1) )   & 
    132132                     &        / MAX(  sss_m(ji,jj), 1.e-20   ) * tmask(ji,jj,1) 
    133                   IF( ln_sssr_bnd )   zerp = SIGN( 1., zerp ) * MIN( zerp_bnd, ABS(zerp) ) 
     133                  IF( ln_sssr_bnd )   zerp = SIGN( 1.0_wp, zerp ) * MIN( zerp_bnd, ABS(zerp) ) 
    134134                  emp(ji,jj) = emp (ji,jj) + zerp 
    135135                  qns(ji,jj) = qns(ji,jj) - zerp * rcp * sst_m(ji,jj) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/SBC/sbcwave.F90

    r13193 r13228  
    199199      ENDIF 
    200200 
    201       CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1., vsd, 'V', -1. ) 
     201      CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp ) 
    202202 
    203203      ! 
    … …  
    212212      END_3D 
    213213      ! 
    214       CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1. ) 
     214      CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1.0_wp ) 
    215215      ! 
    216216      IF( ln_linssh ) THEN   ;   ik = 1   ! none zero velocity through the sea surface 
    … …  
    271271            taum(ji,jj) = SQRT( tauw_x(ji,jj)*tauw_x(ji,jj) + tauw_y(ji,jj)*tauw_y(ji,jj) ) 
    272272         END_2D 
    273          CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1. , vtau(:,:), 'V', -1. , taum(:,:) , 'T', -1. ) 
     273         CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1.0_wp , vtau(:,:), 'V', -1.0_wp , taum(:,:) , 'T', -1.0_wp ) 
    274274      ENDIF 
    275275      ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/STO/stopar.F90

    r13219 r13228  
    687687      INTEGER             ::   idg                 ! number of digits 
    688688      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type 
    689       REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart) 
     689      REAL(KIND=dp)       ::   zrseed(4)           ! RNG seeds in double-precision (with same bits to save in restart) 
    690690      CHARACTER(LEN=9)    ::   clsto2d='sto2d_000' ! stochastic parameter variable name 
    691691      CHARACTER(LEN=9)    ::   clsto3d='sto3d_000' ! stochastic parameter variable name 
    … …  
    749749      INTEGER             ::   idg                 ! number of digits 
    750750      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type 
    751       REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart) 
     751      REAL(KIND=dp)       ::   zrseed(4)           ! RNG seeds in double-precision (with same bits to save in restart) 
    752752      CHARACTER(LEN=20)   ::   clkt                ! ocean time-step defined as a character 
    753753      CHARACTER(LEN=50)   ::   clname              ! restart file name 
    … …  
    835835      !! 
    836836      INTEGER  :: ji, jj 
    837       REAL(KIND=8) :: gran   ! Gaussian random number (forced KIND=8 as in kiss_gaussian) 
     837      REAL(wp) :: gran   ! Gaussian random number (forced KIND=8 as in kiss_gaussian) 
    838838 
    839839      DO_2D_11_11 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TDE/tide_mod.F90

    r12724 r13228  
    723723      !! ** Action  :   pot_astro   actronomical potential 
    724724      !!----------------------------------------------------------------------       
    725       REAL, INTENT(in)              ::   pdelta      ! Temporal offset in seconds 
     725      REAL(wp), INTENT(in)          ::   pdelta      ! Temporal offset in seconds 
    726726      INTEGER, INTENT(IN)           ::   Kmm         ! Time level index 
    727727      INTEGER                       ::   jk          ! Dummy loop index 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/traadv_cen.F90

    r12590 r13228  
    116116               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    117117            END_3D 
    118             CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond. 
     118            CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. 
    119119            ! 
    120120            DO_3D_00_10( 1, jpkm1 ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/traadv_fct.F90

    r12724 r13228  
    9797         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    9898      ENDIF 
     99      !! -- init to 0 
     100      zwi(:,:,:) = 0._wp 
     101      zwx(:,:,:) = 0._wp 
     102      zwy(:,:,:) = 0._wp 
     103      zwz(:,:,:) = 0._wp 
     104      ztu(:,:,:) = 0._wp 
     105      ztv(:,:,:) = 0._wp 
     106      zltu(:,:,:) = 0._wp 
     107      zltv(:,:,:) = 0._wp 
     108      ztw(:,:,:) = 0._wp 
    99109      ! 
    100110      l_trd = .FALSE.            ! set local switches 
    … …  
    224234               END_2D 
    225235            END DO 
    226             CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1. , zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
     236            CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    227237            ! 
    228238            DO_3D_10_10( 1, jpkm1 ) 
    … …  
    241251               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    242252            END_3D 
    243             CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond. (unchanged sgn) 
     253            CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    244254            ! 
    245255            DO_3D_00_00( 1, jpkm1 ) 
    … …  
    293303         END IF 
    294304         ! 
    295          CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1., zwx, 'U', -1. , zwy, 'V', -1.,  zwz, 'W',  1. ) 
     305         CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp,  zwz, 'W',  1.0_wp ) 
    296306         ! 
    297307         !        !==  monotonicity algorithm  ==! 
    … …  
    378388      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    379389      INTEGER  ::   ikm1         ! local integer 
    380       REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn    ! local scalars 
    381       REAL(wp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
    382       REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 
    383       !!---------------------------------------------------------------------- 
    384       ! 
    385       zbig  = 1.e+40_wp 
    386       zrtrn = 1.e-15_wp 
    387       zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp 
     390      REAL(dp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn    ! local scalars 
     391      REAL(dp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
     392      REAL(dp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 
     393      !!---------------------------------------------------------------------- 
     394      ! 
     395      zbig  = 1.e+40_dp 
     396      zrtrn = 1.e-15_dp 
     397      zbetup(:,:,:) = 0._dp   ;   zbetdo(:,:,:) = 0._dp 
    388398 
    389399      ! Search local extrema 
    … …  
    427437         END_2D 
    428438      END DO 
    429       CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1. , zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign) 
     439      CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
    430440 
    431441      ! 3. monotonic flux in the i & j direction (paa & pbb) 
    … …  
    434444         zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    435445         zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
    436          zcu =       ( 0.5  + SIGN( 0.5 , paa(ji,jj,jk) ) ) 
     446         zcu =       ( 0.5  + SIGN( 0.5_wp , paa(ji,jj,jk) ) ) 
    437447         paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 
    438448 
    439449         zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 
    440450         zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 
    441          zcv =       ( 0.5  + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 
     451         zcv =       ( 0.5  + SIGN( 0.5_wp , pbb(ji,jj,jk) ) ) 
    442452         pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
    443453 
    … …  
    446456         za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 
    447457         zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
    448          zc =       ( 0.5  + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 
     458         zc =       ( 0.5  + SIGN( 0.5_wp , pcc(ji,jj,jk+1) ) ) 
    449459         pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
    450460      END_3D 
    451       CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1. , pbb, 'V', -1. )   ! lateral boundary condition (changed sign) 
     461      CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp )   ! lateral boundary condition (changed sign) 
    452462      ! 
    453463   END SUBROUTINE nonosc 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/traadv_mus.F90

    r12590 r13228  
    137137         END_3D 
    138138         ! lateral boundary conditions   (changed sign) 
    139          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) 
     139         CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 
    140140         !                                !-- Slopes of tracer 
    141141         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    142142         zslpy(:,:,jpk) = 0._wp 
    143143         DO_3D_01_01( 1, jpkm1 ) 
    144             zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    145                &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
    146             zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   & 
    147                &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) ) 
     144            zslpx(ji,jj,jk) =                       ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
     145               &            * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
     146            zslpy(ji,jj,jk) =                       ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   & 
     147               &            * ( 0.25 + SIGN( 0.25_wp, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) ) 
    148148         END_3D 
    149149         ! 
    150150         DO_3D_01_01( 1, jpkm1 ) 
    151             zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    152                &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
    153                &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) ) 
    154             zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   & 
    155                &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   & 
    156                &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) ) 
     151            zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
     152               &                                                     2.*ABS( zwx  (ji-1,jj,jk) ),   & 
     153               &                                                     2.*ABS( zwx  (ji  ,jj,jk) ) ) 
     154            zslpy(ji,jj,jk) = SIGN( 1.0_wp, zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   & 
     155               &                                                     2.*ABS( zwy  (ji,jj-1,jk) ),   & 
     156               &                                                     2.*ABS( zwy  (ji,jj  ,jk) ) ) 
    157157         END_3D 
    158158         ! 
    159159         DO_3D_00_00( 1, jpkm1 ) 
    160160            ! MUSCL fluxes 
    161             z0u = SIGN( 0.5, pU(ji,jj,jk) ) 
     161            z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) 
    162162            zalpha = 0.5 - z0u 
    163163            zu  = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
    … …  
    166166            zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    167167            ! 
    168             z0v = SIGN( 0.5, pV(ji,jj,jk) ) 
     168            z0v = SIGN( 0.5_wp, pV(ji,jj,jk) ) 
    169169            zalpha = 0.5 - z0v 
    170170            zv  = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
    … …  
    173173            zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    174174         END_3D 
    175          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign) 
     175         CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! lateral boundary conditions   (changed sign) 
    176176         ! 
    177177         DO_3D_00_00( 1, jpkm1 ) 
    … …  
    201201         zslpx(:,:,1) = 0._wp                   ! surface values 
    202202         DO_3D_11_11( 2, jpkm1 ) 
    203             zslpx(ji,jj,jk) =                     ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
    204                &            * (  0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
     203            zslpx(ji,jj,jk) =                        ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
     204               &            * (  0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
    205205         END_3D 
    206206         DO_3D_11_11( 2, jpkm1 ) 
    207             zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    208                &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
    209                &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  ) 
     207            zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
     208               &                                                     2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     209               &                                                     2.*ABS( zwx  (ji,jj,jk  ) )  ) 
    210210         END_3D 
    211211         DO_3D_00_00( 1, jpk-2 ) 
    212             z0w = SIGN( 0.5, pW(ji,jj,jk+1) ) 
     212            z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) 
    213213            zalpha = 0.5 + z0w 
    214214            zw  = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/traadv_qck.F90

    r12606 r13228  
    146146            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
    147147         END_3D 
    148          CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions 
    149  
     148         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions  
     149          
    150150         ! 
    151151         ! Horizontal advective fluxes 
    152152         ! --------------------------- 
    153153         DO_3D_00_00( 1, jpkm1 ) 
    154             zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
    155             zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T 
    156          END_3D 
    157          ! 
    158          DO_3D_00_00( 1, jpkm1 ) 
    159             zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
    160             zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) )   & 
    161                &         * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     154            zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     155            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
     156         END_3D 
     157         ! 
     158         DO_3D_00_00( 1, jpkm1 ) 
     159            zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     160            zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    162161            zwx(ji,jj,jk)  = ABS( pU(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    163162            zfc(ji,jj,jk)  = zdir * pt(ji  ,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji+1,jj,jk,jn,Kbb)  ! FC in the x-direction for T 
    … …  
    165164         END_3D 
    166165         !--- Lateral boundary conditions 
    167          CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1.,  zwx(:,:,:), 'T', 1. ) 
     166         CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp,  zwx(:,:,:), 'T', 1.0_wp ) 
    168167 
    169168         !--- QUICKEST scheme 
    … …  
    174173            zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
    175174         END_3D 
    176          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )      ! Lateral boundary conditions 
     175         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )      ! Lateral boundary conditions  
    177176 
    178177         ! 
    … …  
    181180            ! 
    182181            DO_2D_00_00 
    183                zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     182               zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    184183               !--- If the second ustream point is a land point 
    185184               !--- the flux is computed by the 1st order UPWIND scheme 
    … …  
    190189         END DO 
    191190         ! 
    192          CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1. ) ! Lateral boundary conditions 
     191         CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 
    193192         ! 
    194193         ! Computation of the trend 
    … …  
    241240            END_2D 
    242241         END DO 
    243          CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions 
     242         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions  
    244243 
    245244 
    … …  
    249248         ! 
    250249         DO_3D_00_00( 1, jpkm1 ) 
    251             zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
    252             zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T 
    253          END_3D 
    254          ! 
    255          DO_3D_00_00( 1, jpkm1 ) 
    256             zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
    257             zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) )   & 
    258                &         * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     250            zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     251            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
     252         END_3D 
     253         ! 
     254         DO_3D_00_00( 1, jpkm1 ) 
     255            zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     256            zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    259257            zwy(ji,jj,jk)  = ABS( pV(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    260258            zfc(ji,jj,jk)  = zdir * pt(ji,jj  ,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji,jj+1,jk,jn,Kbb)  ! FC in the x-direction for T 
    … …  
    263261 
    264262         !--- Lateral boundary conditions 
    265          CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwy(:,:,:), 'T', 1. ) 
     263         CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 
    266264 
    267265         !--- QUICKEST scheme 
    … …  
    272270            zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
    273271         END_3D 
    274          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )    !--- Lateral boundary conditions 
     272         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )    !--- Lateral boundary conditions  
    275273         ! 
    276274         ! Tracer flux on the x-direction 
    … …  
    278276            ! 
    279277            DO_2D_00_00 
    280                zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     278               zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    281279               !--- If the second ustream point is a land point 
    282280               !--- the flux is computed by the 1st order UPWIND scheme 
    … …  
    287285         END DO 
    288286         ! 
    289          CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1. ) ! Lateral boundary conditions 
     287         CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 
    290288         ! 
    291289         ! Computation of the trend 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/traadv_ubs.F90

    r12590 r13228  
    138138            ! 
    139139         END DO 
    140          CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. )   ;    CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
     140         CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp )   ;    CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    141141         ! 
    142142         DO_3D_10_10( 1, jpkm1 ) 
    … …  
    209209               zti(ji,jj,jk)    = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    210210            END_3D 
    211             CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1. )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
     211            CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1.0_wp )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    212212            ! 
    213213            !                          !*  anti-diffusive flux : high order minus low order 
    … …  
    274274      !!---------------------------------------------------------------------- 
    275275      ! 
    276       zbig  = 1.e+40_wp 
     276      zbig  = 1.e+38_wp 
    277277      zrtrn = 1.e-15_wp 
    278278      zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp 
    … …  
    325325         za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) 
    326326         zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) 
    327          zc = 0.5 * ( 1.e0 + SIGN( 1.e0, pcc(ji,jj,jk) ) ) 
     327         zc = 0.5 * ( 1.e0 + SIGN( 1.0_wp, pcc(ji,jj,jk) ) ) 
    328328         pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) 
    329329      END_3D 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/traatf.F90

    r12724 r13228  
    110110#endif 
    111111      !                                              ! local domain boundaries  (T-point, unchanged sign) 
    112       CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) 
     112      CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 
    113113      ! 
    114114      IF( ln_bdy )   CALL bdy_tra( kt, Kbb, pts, Kaa )  ! BDY open boundaries 
    … …  
    156156         ENDIF 
    157157         ! 
    158          CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1., pts(:,:,:,jp_sal,Kbb) , 'T', 1., & 
    159                   &                    pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1., & 
    160                   &                    pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1.  ) 
     158         CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kbb) , 'T', 1.0_wp, & 
     159                  &                    pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp, & 
     160                  &                    pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp  ) 
    161161         ! 
    162162      ENDIF 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/trabbc.F90

    r12724 r13228  
    9696      END_2D 
    9797      ! 
    98       CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1. ) 
     98      CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1.0_wp ) 
    9999      ! 
    100100      IF( l_trdtra ) THEN        ! Send the trend for diagnostics 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/trabbl.F90

    r12590 r13228  
    126126            &          tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    127127         ! lateral boundary conditions ; just need for outputs 
    128          CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1. , ahv_bbl, 'V', 1. ) 
     128         CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1.0_wp , ahv_bbl, 'V', 1.0_wp ) 
    129129         CALL iom_put( "ahu_bbl", ahu_bbl )   ! bbl diffusive flux i-coef 
    130130         CALL iom_put( "ahv_bbl", ahv_bbl )   ! bbl diffusive flux j-coef 
    … …  
    139139            &          tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    140140         ! lateral boundary conditions ; just need for outputs 
    141          CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1. , vtr_bbl, 'V', 1. ) 
     141         CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 
    142142         CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport 
    143143         CALL iom_put( "voce_bbl", vtr_bbl )  ! bbl j-transport 
    … …  
    366366               &      - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    367367            ! 
    368             zsign  = SIGN(  0.5, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
     368            zsign  = SIGN(  0.5_wp, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
    369369            ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)       ! masked diffusive flux coeff. 
    370370            ! 
    … …  
    376376               &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
    377377            ! 
    378             zsign = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
     378            zsign = SIGN(  0.5_wp, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
    379379            ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
    380380         END_2D 
    … …  
    396396                         - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    397397               ! 
    398                zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope 
    399                zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope 
     398               zsign = SIGN(  0.5_wp, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope 
     399               zsigna= SIGN(  0.5_wp, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope 
    400400               ! 
    401401               !                                                          ! bbl velocity 
    … …  
    408408               zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
    409409                  &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
    410                zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope 
    411                zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope 
     410               zsign = SIGN(  0.5_wp, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope 
     411               zsigna= SIGN(  0.5_wp, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope 
    412412               ! 
    413413               !                                                          ! bbl transport 
    … …  
    514514      END_2D 
    515515      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    516       zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 
    517       CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1., zmbkv,'V',1.) 
     516      zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp )   
     517      CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp)  
    518518      mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ;  mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) 
    519519      ! 
    … …  
    522522      DO_2D_10_10 
    523523         IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
    524             mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     524            mgrhu(ji,jj) = INT(  SIGN( 1.0_wp, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    525525         ENDIF 
    526526         ! 
    527527         IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
    528             mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     528            mgrhv(ji,jj) = INT(  SIGN( 1.0_wp, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    529529         ENDIF 
    530530      END_2D 
    … …  
    534534         e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
    535535      END_2D 
    536       CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1. , e3v_bbl_0, 'V', 1. )      ! lateral boundary conditions 
     536      CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp )      ! lateral boundary conditions 
    537537      ! 
    538538      !                             !* masked diffusive flux coefficients 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/traldf_lap_blp.F90

    r12590 r13228  
    200200      END SELECT 
    201201      ! 
    202       CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1. )     ! Lateral boundary conditions (unchanged sign) 
     202      CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp )     ! Lateral boundary conditions (unchanged sign) 
    203203      !                                               ! Partial top/bottom cell: GRADh( zlap ) 
    204204      IF( ln_isfcav .AND. ln_zps ) THEN   ;   CALL zps_hde_isf( kt, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi )  ! both top & bottom 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/tramle.F90

    r12724 r13228  
    289289               rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
    290290            END_2D 
    291             CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1. , rfv, 'V', 1. ) 
     291            CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 
    292292            ! 
    293293         ELSEIF( nn_mle == 1 ) THEN           ! MLE array allocation & initialisation 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/tranpc.F90

    r12724 r13228  
    310310         ENDIF 
    311311         ! 
    312          CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) 
     312         CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 
    313313         ! 
    314314         IF( lwp .AND. l_LB_debug ) THEN 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/trazdf.F90

    r12724 r13228  
    9595         END DO 
    9696!!gm this should be moved in trdtra.F90 and done on all trends 
    97          CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1. , ztrds, 'T', 1. ) 
     97         CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 
    9898!!gm 
    9999         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRA/zpshde.F90

    r12622 r13228  
    146146      END DO 
    147147      ! 
    148       CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1. )   ! Lateral boundary cond. 
     148      CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    149149      !                 
    150150      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    … …  
    179179            ENDIF 
    180180         END_2D 
    181          CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions 
     181         CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    182182         ! 
    183183      END IF 
    … …  
    302302      END DO 
    303303      ! 
    304       CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1. )   ! Lateral boundary cond. 
     304      CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    305305 
    306306      ! horizontal derivative of density anomalies (rd) 
    … …  
    344344         END_2D 
    345345 
    346          CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions 
     346         CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    347347         ! 
    348348      END IF 
    … …  
    395395         ! 
    396396      END DO 
    397       CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1. , pgtvi(:,:,:), 'V', -1. )   ! Lateral boundary cond. 
     397      CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    398398 
    399399      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    … …  
    434434 
    435435         END_2D 
    436          CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1. , pgrvi, 'V', -1. )   ! Lateral boundary conditions 
     436         CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp )   ! Lateral boundary conditions 
    437437         ! 
    438438      END IF   

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRD/trddyn.F90

    r12724 r13228  
    128128                                 z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) 
    129129                              END_3D 
    130                               CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1., z3dy, 'V', -1. ) 
     130                              CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 
    131131                              CALL iom_put( "utrd_udx", z3dx  ) 
    132132                              CALL iom_put( "vtrd_vdy", z3dy  ) 
    … …  
    164164!                                 END DO 
    165165!                              END DO 
    166 !                              CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1., z3dy, 'V', -1. ) 
     166!                              CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 
    167167!                              CALL iom_put( "utrd_bfr", z3dx ) 
    168168!                              CALL iom_put( "vtrd_bfr", z3dy ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRD/trdken.F90

    r12724 r13228  
    9090      !!---------------------------------------------------------------------- 
    9191      ! 
    92       CALL lbc_lnk_multi( 'trdken', putrd, 'U', -1. , pvtrd, 'V', -1. )      ! lateral boundary conditions 
     92      CALL lbc_lnk_multi( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp )      ! lateral boundary conditions 
    9393      ! 
    9494      nkstp = kt 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRD/trdmxl.F90

    r12616 r13228  
    154154!!gm to be put juste before the output ! 
    155155!      ! Lateral boundary conditions 
    156 !      CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1. , smltrd(:,:,jl), 'T', 1. ) 
     156!      CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1.0_wp , smltrd(:,:,jl), 'T', 1.0_wp ) 
    157157!!gm end 
    158158 
    … …  
    472472         !-- Lateral boundary conditions 
    473473         !         ... temperature ...                    ... salinity ... 
    474          CALL lbc_lnk_multi( 'trdmxl', ztmltot , 'T', 1., zsmltot , 'T', 1., & 
    475                   &          ztmlres , 'T', 1., zsmlres , 'T', 1., & 
    476                   &          ztmlatf , 'T', 1., zsmlatf , 'T', 1. ) 
     474         CALL lbc_lnk_multi( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & 
     475                  &          ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & 
     476                  &          ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) 
    477477 
    478478 
    … …  
    523523         !-- Lateral boundary conditions 
    524524         !         ... temperature ...                    ... salinity ... 
    525          CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1., zsmltot2, 'T', 1., & 
    526                   &          ztmlres2, 'T', 1., zsmlres2, 'T', 1. ) 
    527          ! 
    528          CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1., zsmltrd2(:,:,:), 'T', 1. ) ! /  in the NetCDF trends file 
     525         CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & 
     526                  &          ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) 
     527         ! 
     528         CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! /  in the NetCDF trends file 
    529529          
    530530         ! III.3 Time evolution array swap 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRD/trdtrc.F90

    r12377 r13228  
    11MODULE trdtrc 
     2   USE par_kind 
    23   !!====================================================================== 
    34   !!                       ***  MODULE trdtrc  *** 
    … …  
    1213      INTEGER ::   kt, kjn, ktrd    
    1314      INTEGER ::   Kmm            ! time level index 
    14       REAL    ::   ptrtrd(:,:,:)   
     15      REAL(wp)::   ptrtrd(:,:,:)   
    1516      WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) 
    1617      WRITE(*,*) '  "      "      : You should not have seen this print! error?', kjn, ktrd, kt 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/TRD/trdvor.F90

    r12724 r13228  
    162162 
    163163      zudpvor(:,:) = 0._wp                 ;   zvdpvor(:,:) = 0._wp                    ! Initialisation 
    164       CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1. )      ! lateral boundary condition 
     164      CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp )      ! lateral boundary condition 
    165165       
    166166 
    … …  
    251251      zvdpvor(:,:) = 0._wp 
    252252      !                            ! lateral boundary condition on input momentum trends 
    253       CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1. ) 
     253      CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) 
    254254 
    255255      !  ===================================== 
    … …  
    400400 
    401401         ! Boundary conditions 
    402          CALL lbc_lnk_multi( 'trdvor', vor_avrtot, 'F', 1. , vor_avrres, 'F', 1. ) 
     402         CALL lbc_lnk_multi( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) 
    403403 
    404404 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/USR/usrdef_sbc.F90

    r12724 r13228  
    181181         wndm(ji,jj) = SQRT( zmod * zcoef ) 
    182182      END_2D 
    183       CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1. , wndm(:,:), 'T', 1. ) 
     183      CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp ) 
    184184 
    185185      ! ---------------------------------- ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/USR/usrdef_zgr.F90

    r13193 r13228  
    200200      z2d(:,:) = REAL( jpkm1 , wp )          ! flat bottom 
    201201      ! 
    202       CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. )           ! set surrounding land to zero (here jperio=0 ==>> closed) 
     202      CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1.0_wp )           ! set surrounding land to zero (here jperio=0 ==>> closed) 
    203203      ! 
    204204      k_bot(:,:) = NINT( z2d(:,:) )          ! =jpkm1 over the ocean point, =0 elsewhere 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ZDF/zdfddm.F90

    r12622 r13228  
    7777      REAL(wp) ::   zaw, zbw, zrw   ! local scalars 
    7878      REAL(wp) ::   zdt, zds 
    79       REAL(wp) ::   zinr, zrr       !   -      - 
    80       REAL(wp) ::   zavft, zavfs    !   -      - 
     79      REAL(wp) ::   zinr            !   -      - 
     80      REAL(dp) ::         zrr       !   -      - 
     81      REAL(wp) ::   zavft           !   -      - 
     82      REAL(dp) ::          zavfs    !   -      - 
    8183      REAL(wp) ::   zavdt, zavds    !   -      - 
    8284      REAL(wp), DIMENSION(jpi,jpj) ::   zrau, zmsks, zmskf, zmskd1, zmskd2, zmskd3 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ZDF/zdfosm.F90

    r12732 r13228  
    12231223 
    12241224       ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids 
    1225        CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1. ) 
     1225       CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1.0_wp ) 
    12261226 
    12271227       ! GN 25/8: need to change tmask --> wmask 
    … …  
    12321232     END_3D 
    12331233      ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid  (sign unchanged), needed to caclulate gham[uv] on u and v grids 
    1234      CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1. , p_avm, 'W', 1.,   & 
    1235       &                  ghamu, 'W', 1. , ghamv, 'W', 1. ) 
     1234     CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1.0_wp , p_avm, 'W', 1.0_wp,   & 
     1235      &                  ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp ) 
    12361236       DO_3D_00_00( 2, jpkm1 ) 
    12371237            ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) & 
    … …  
    12461246        ! Lateral boundary conditions on final outputs for gham[ts],  on W-grid  (sign unchanged) 
    12471247        ! Lateral boundary conditions on final outputs for gham[uv],  on [UV]-grid  (sign unchanged) 
    1248         CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1. , ghams, 'W', 1.,   & 
    1249          &                  ghamu, 'U', 1. , ghamv, 'V', 1. ) 
     1248        CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W', 1.0_wp,   & 
     1249         &                  ghamu, 'U', 1.0_wp , ghamv, 'V', 1.0_wp ) 
    12501250 
    12511251       IF(ln_dia_osm) THEN 
    … …  
    12871287      END IF 
    12881288      ! Lateral boundary conditions on p_avt  (sign unchanged) 
    1289       CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1. ) 
     1289      CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1.0_wp ) 
    12901290      ! 
    12911291   END SUBROUTINE zdf_osm 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ZDF/zdfphy.F90

    r12377 r13228  
    302302      !                                         !* Lateral boundary conditions (sign unchanged) 
    303303      IF( l_zdfsh2 ) THEN 
    304          CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1. , avt_k, 'W', 1.,   & 
    305             &                avm  , 'W', 1. , avt  , 'W', 1. , avs , 'W', 1. ) 
     304         CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp,   & 
     305            &                avm  , 'W', 1.0_wp , avt  , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 
    306306      ELSE 
    307          CALL lbc_lnk_multi( 'zdfphy', avm  , 'W', 1. , avt  , 'W', 1. , avs , 'W', 1. ) 
     307         CALL lbc_lnk_multi( 'zdfphy', avm  , 'W', 1.0_wp , avt  , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 
    308308      ENDIF 
    309309      ! 
    310310      IF( l_zdfdrg ) THEN     ! drag  have been updated (non-linear cases) 
    311          IF( ln_isfcav ) THEN   ;  CALL lbc_lnk_multi( 'zdfphy', rCdU_top, 'T', 1. , rCdU_bot, 'T', 1. )   ! top & bot drag 
    312          ELSE                   ;  CALL lbc_lnk      ( 'zdfphy', rCdU_bot, 'T', 1. )                       ! bottom drag only 
     311         IF( ln_isfcav ) THEN   ;  CALL lbc_lnk_multi( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp )   ! top & bot drag 
     312         ELSE                   ;  CALL lbc_lnk      ( 'zdfphy', rCdU_bot, 'T', 1.0_wp )                       ! bottom drag only 
    313313         ENDIF 
    314314      ENDIF 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/ZDF/zdftke.F90

    r13193 r13228  
    312312         DO_3D_00_00( 2, jpkm1 ) 
    313313            !                             ! local Richardson number 
    314             zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 
     314            IF (rn2b(ji,jj,jk) <= 0.0_wp) then 
     315                zri = 0.0_wp 
     316            ELSE 
     317                zri = rn2b(ji,jj,jk) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 
     318            ENDIF 
    315319            !                             ! inverse of Prandtl number 
    316320            apdlr(ji,jj,jk) = MAX(  0.1_wp,  ri_cri / MAX( ri_cri , zri )  ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/lib_fortran.F90

    r12377 r13228  
    143143      !!---------------------------------------------------------------------- 
    144144      REAL(wp),  INTENT(in   ) ::   ptab(:,:) ! array on which operation is applied 
    145       COMPLEX(wp)              ::  local_sum_2d 
    146       ! 
    147       !!----------------------------------------------------------------------- 
    148       ! 
    149       COMPLEX(wp)::   ctmp 
     145      COMPLEX(dp)              ::  local_sum_2d 
     146      ! 
     147      !!----------------------------------------------------------------------- 
     148      ! 
     149      COMPLEX(dp)::   ctmp 
    150150      REAL(wp)   ::   ztmp 
    151151      INTEGER    ::   ji, jj    ! dummy loop indices 
    … …  
    161161         DO ji = 1, ipi 
    162162            ztmp =  ptab(ji,jj) * tmask_i(ji,jj) 
    163             CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
     163            CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 
    164164         END DO 
    165165      END DO 
    … …  
    172172      !!---------------------------------------------------------------------- 
    173173      REAL(wp),  INTENT(in   ) ::   ptab(:,:,:) ! array on which operation is applied 
    174       COMPLEX(wp)              ::  local_sum_3d 
    175       ! 
    176       !!----------------------------------------------------------------------- 
    177       ! 
    178       COMPLEX(wp)::   ctmp 
     174      COMPLEX(dp)              ::  local_sum_3d 
     175      ! 
     176      !!----------------------------------------------------------------------- 
     177      ! 
     178      COMPLEX(dp)::   ctmp 
    179179      REAL(wp)   ::   ztmp 
    180180      INTEGER    ::   ji, jj, jk   ! dummy loop indices 
    … …  
    192192          DO ji = 1, ipi 
    193193             ztmp =  ptab(ji,jj,jk) * tmask_i(ji,jj) 
    194              CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
     194             CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 
    195195          END DO 
    196196        END DO 
    … …  
    226226         ENDIF 
    227227      END_2D 
    228       CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. ) 
     228      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 
    229229      IF( nbondi /= -1 ) THEN 
    230230         IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:) 
    … …  
    243243         IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj) 
    244244      ENDIF 
    245       CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1. ) 
     245      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 
    246246 
    247247   END SUBROUTINE sum3x3_2d 
    … …  
    274274         END_2D 
    275275      END DO 
    276       CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. ) 
     276      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 
    277277      IF( nbondi /= -1 ) THEN 
    278278         IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:) 
    … …  
    291291         IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:) 
    292292      ENDIF 
    293       CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1. ) 
     293      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 
    294294 
    295295   END SUBROUTINE sum3x3_3d 
    … …  
    313313      !!              Yun HE and Chris H. Q. DING, Journal of Supercomputing 18, 259-277, 2001 
    314314      !!---------------------------------------------------------------------- 
    315       COMPLEX(wp), INTENT(in   ) ::   ydda 
    316       COMPLEX(wp), INTENT(inout) ::   yddb 
    317       ! 
    318       REAL(wp) :: zerr, zt1, zt2  ! local work variables 
     315      COMPLEX(dp), INTENT(in   ) ::   ydda 
     316      COMPLEX(dp), INTENT(inout) ::   yddb 
     317      ! 
     318      REAL(dp) :: zerr, zt1, zt2  ! local work variables 
    319319      !!----------------------------------------------------------------------- 
    320320      ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/lib_fortran_generic.h90

    r10425 r13228  
    4040      REAL(wp)                              ::   FUNCTION_GLOB_OP   ! global sum 
    4141      !! 
    42       COMPLEX(wp)::   ctmp 
     42      COMPLEX(dp)::   ctmp 
    4343      REAL(wp)   ::   ztmp 
    4444      INTEGER    ::   ji, jj, jk   ! dummy loop indices 
    … …  
    5050      ipk = K_SIZE(ptab)   ! 3rd dimension 
    5151      ! 
    52       ctmp = CMPLX( 0.e0, 0.e0, wp )   ! warning ctmp is cumulated 
     52      ctmp = CMPLX( 0.e0, 0.e0, dp )   ! warning ctmp is cumulated 
    5353    
    5454      DO jk = 1, ipk 
    … …  
    5656          DO ji = 1, ipi 
    5757             ztmp =  ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) 
    58              CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
     58             CALL DDPDD( CMPLX( ztmp, 0.e0, dp ), ctmp ) 
    5959          END DO 
    6060        END DO 
    … …  
    109109      REAL(wp)                              ::   FUNCTION_GLOB_OP   ! global sum 
    110110      !! 
    111       COMPLEX(wp)::   ctmp 
     111      COMPLEX(dp)::   ctmp 
    112112      REAL(wp)   ::   ztmp 
    113113      INTEGER    ::   jk       ! dummy loop indices 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/nemogcm.F90

    r13219 r13228  
    374374         WRITE(numout,*) "     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 
    375375         WRITE(numout,*) 
     376          
     377         ! Print the working precision to ocean.output 
     378         IF (wp == dp) THEN 
     379            WRITE(numout,*) "Working precision = double-precision" 
     380         ELSE 
     381            WRITE(numout,*) "Working precision = single-precision" 
     382         ENDIF 
     383         WRITE(numout,*) 
    376384         ! 
    377385         WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/par_kind.F90

    r13219 r13228  
    2424   INTEGER, PUBLIC, PARAMETER ::   sp = SELECTED_REAL_KIND( 6, 37)   !: single precision (real 4) 
    2525   INTEGER, PUBLIC, PARAMETER ::   dp = SELECTED_REAL_KIND(12,307)   !: double precision (real 8) 
     26# if defined key_single 
     27   INTEGER, PUBLIC, PARAMETER ::   wp = sp                              !: working precision 
     28# else 
    2629   INTEGER, PUBLIC, PARAMETER ::   wp = dp                              !: working precision 
     30# endif 
    2731 
    2832   !                                                                !!** Integer ** 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/PISCES/P2Z/p2zbio.F90

    r12680 r13228  
    339339      ! 
    340340      IF( lk_iomput ) THEN 
    341          CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1. ) 
    342          CALL lbc_lnk_multi( 'p2zbio', zw3d(:,:,:,1),'T', 1., zw3d(:,:,:,2),'T', 1., zw3d(:,:,:,3),'T', 1. ) 
     341         CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1.0_wp ) 
     342         CALL lbc_lnk_multi( 'p2zbio', zw3d(:,:,:,1),'T', 1.0_wp, zw3d(:,:,:,2),'T', 1.0_wp, zw3d(:,:,:,3),'T', 1.0_wp ) 
    343343         ! Save diagnostics 
    344344         CALL iom_put( "TNO3PHY", zw2d(:,:,1) ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/PISCES/P2Z/p2zexp.F90

    r12724 r13228  
    107107      END_2D 
    108108 
    109       CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1. ) 
     109      CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1.0_wp ) 
    110110  
    111111      ! Oa & Ek: diagnostics depending on jpdia2d !          left as example 
    … …  
    210210         END IF 
    211211      END_2D 
    212       CALL lbc_lnk( 'p2zexp', cmask , 'T', 1. )      ! lateral boundary conditions on cmask   (sign unchanged) 
     212      CALL lbc_lnk( 'p2zexp', cmask , 'T', 1.0_wp )      ! lateral boundary conditions on cmask   (sign unchanged) 
    213213      areacot = glob_sum( 'p2zexp', e1e2t(:,:) * cmask(:,:) ) 
    214214      ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/PISCES/P4Z/p4zbc.F90

    r12680 r13228  
    311311         END_3D 
    312312         ! 
    313          CALL lbc_lnk( 'p4zbc', zcmask , 'T', 1. )      ! lateral boundary conditions on cmask   (sign unchanged) 
     313         CALL lbc_lnk( 'p4zbc', zcmask , 'T', 1.0_wp )      ! lateral boundary conditions on cmask   (sign unchanged) 
    314314         ! 
    315315         DO_3D_11_11( 1, jpk ) 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/PISCES/P4Z/p4zopt.F90

    r12680 r13228  
    402402      ! 
    403403      CALL trc_oce_rgb( xkrgb )                  ! tabulated attenuation coefficients 
    404       nksrp = trc_oce_ext_lev( r_si2, 0.33e2 )     ! max level of light extinction (Blue Chl=0.01) 
     404      nksrp = trc_oce_ext_lev( r_si2, 0.33e2_wp )     ! max level of light extinction (Blue Chl=0.01) 
    405405      ! 
    406406      IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m' 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/TRP/trcsbc.F90

    r12779 r13228  
    155155      END SELECT 
    156156      ! 
    157       CALL lbc_lnk( 'trcsbc', sbc_trc(:,:,:), 'T', 1. ) 
     157      CALL lbc_lnk( 'trcsbc', sbc_trc(:,:,:), 'T', 1.0_wp ) 
    158158      !                                       Concentration dilution effect on tracers due to evaporation & precipitation  
    159159      DO jn = 1, jptra 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/TRP/trcsink.F90

    r12680 r13228  
    158158            ! slopes 
    159159            DO jk = 2, jpkm1 
    160                zign = 0.25 + SIGN( 0.25, ztraz(ji,jj,jk) * ztraz(ji,jj,jk+1) ) 
     160               zign = 0.25 + SIGN( 0.25_wp, ztraz(ji,jj,jk) * ztraz(ji,jj,jk+1) ) 
    161161               zakz(ji,jj,jk) = ( ztraz(ji,jj,jk) + ztraz(ji,jj,jk+1) ) * zign 
    162162            END DO 
    … …  
    164164            ! Slopes limitation 
    165165            DO jk = 2, jpkm1 
    166                zakz(ji,jj,jk) = SIGN( 1., zakz(ji,jj,jk) ) *        & 
     166               zakz(ji,jj,jk) = SIGN( 1.0_wp, zakz(ji,jj,jk) ) *        & 
    167167                  &             MIN( ABS( zakz(ji,jj,jk) ), 2. * ABS(ztraz(ji,jj,jk+1)), 2. * ABS(ztraz(ji,jj,jk) ) ) 
    168168            END DO 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/TRP/trdtrc.F90

    r12377 r13228  
    1818   USE trdmxl_trc        ! Mixed layer trends diag. 
    1919   USE iom               ! I/O library 
     20   USE par_kind 
    2021 
    2122   IMPLICIT NONE 
    … …  
    107108   !!---------------------------------------------------------------------- 
    108109 
     110   USE par_kind 
     111 
    109112   PUBLIC trd_trc 
    110113 
    … …  
    116119      INTEGER               , INTENT( in )     ::   kjn     ! tracer index 
    117120      INTEGER               , INTENT( in )     ::   ktrd    ! tracer trend index 
    118       REAL, DIMENSION(:,:,:), INTENT( inout )  ::   ptrtrd  ! Temperature or U trend 
     121      REAL(wp), DIMENSION(:,:,:), INTENT( inout )  ::   ptrtrd  ! Temperature or U trend 
    119122      WRITE(*,*) 'trd_trc : You should not have seen this print! error?', ptrtrd(1,1,1) 
    120123      WRITE(*,*) '  "      "      : You should not have seen this print! error?', kjn 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/TOP/trcbdy.F90

    r12377 r13228  
    9696         END DO 
    9797         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    98             CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T',  1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     98            CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T',  1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    9999         END IF 
    100100         ! 

  • NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/tests/STATION_ASF/EXPREF/launch_sasf.sh

    r13217 r13228  
    1515WORK_DIR="${HOME}/tmp/STATION_ASF" 
    1616 
    17  
    18 # FORC_DIR => Directory containing sea-surface + atmospheric forcings 
     17# DATA_IN_DIR => Directory containing sea-surface + atmospheric forcings 
    1918#             (get it there https://drive.google.com/file/d/1MxNvjhRHmMrL54y6RX7WIaM9-LGl--ZP/): 
    2019if [ `hostname` = "merlat"        ]; then 
    21     FORC_DIR="/MEDIA/data/STATION_ASF/input_data_STATION_ASF_2016-2018" 
     20    DATA_IN_DIR="/MEDIA/data/STATION_ASF/input_data_STATION_ASF_2016-2018" 
    2221elif [ `hostname` = "luitel"        ]; then 
    23     FORC_DIR="/data/gcm_setup/STATION_ASF/input_data_STATION_ASF_2016-2018" 
     22    DATA_IN_DIR="/data/gcm_setup/STATION_ASF/input_data_STATION_ASF_2016-2018" 
    2423elif [ `hostname` = "ige-meom-cal1" ]; then 
    25     FORC_DIR="/mnt/meom/workdir/brodeau/STATION_ASF/input_data_STATION_ASF_2016-2018" 
     24    DATA_IN_DIR="/mnt/meom/workdir/brodeau/STATION_ASF/input_data_STATION_ASF_2016-2018" 
    2625elif [ `hostname` = "salvelinus" ]; then 
    27     FORC_DIR="/opt/data/STATION_ASF/input_data_STATION_ASF_2016-2018" 
     26    DATA_IN_DIR="/opt/data/STATION_ASF/input_data_STATION_ASF_2016-2018" 
    2827else 
    29     echo "Boo!"; exit 
     28    echo "Oops! We don't know `hostname` yet! Define 'DATA_IN_DIR' in the script!"; exit  
    3029fi 
    31 #====================== 
    32 mkdir -p ${WORK_DIR} 
    3330 
    3431 
    3532if [ ! -f ${NEMO_EXE} ]; then echo " Mhhh, no compiled nemo.exe found into ${NEMO_DIR}/tests/STATION_ASF/BLD/bin !"; exit; fi 
    3633 
    37 NEMO_EXPREF="${NEMO_DIR}/tests/STATION_ASF/EXPREF" 
     34# NEMOGCM root directory where to fetch compiled STATION_ASF nemo.exe + setup: 
     35NEMO_WRK_DIR=`pwd | sed -e "s|/tests/STATION_ASF/${expdir}||g"` 
     36 
     37# Directory where to run the simulation: 
     38PROD_DIR="${HOME}/tmp/STATION_ASF" 
     39 
     40 
     41####### End of normal user configurable section ####### 
     42 
     43#================================================================================ 
     44 
     45# NEMO executable to use is: 
     46NEMO_EXE="${NEMO_WRK_DIR}/tests/${TC_DIR}/BLD/bin/nemo.exe" 
     47 
     48 
     49echo "###########################################################" 
     50echo "#        S T A T I O N   A i r  -  S e a   F l u x        #" 
     51echo "###########################################################" 
     52echo 
     53echo " We shall work in here: ${STATION_ASF_DIR}/" 
     54echo " NEMOGCM   work    depository is: ${NEMO_WRK_DIR}/" 
     55echo "   ==> NEMO EXE to use: ${NEMO_EXE}" 
     56echo " Input forcing data into: ${DATA_IN_DIR}/" 
     57echo " Production will be done into: ${PROD_DIR}/" 
     58echo 
     59 
     60mkdir -p ${PROD_DIR} 
     61 
     62if [ ! -f ${NEMO_EXE} ]; then echo " Mhhh, no compiled 'nemo.exe' found into `dirname ${NEMO_EXE}` !"; exit; fi 
     63 
     64echo 
     65echo " *** Using the following NEMO executable:" 
     66echo "  ${NEMO_EXE} " 
     67echo 
     68 
     69NEMO_EXPREF="${NEMO_WRK_DIR}/tests/STATION_ASF/EXPREF" 
    3870if [ ! -d ${NEMO_EXPREF} ]; then echo " Mhhh, no EXPREF directory ${NEMO_EXPREF} !"; exit; fi 
    3971 
    40 rsync -avP ${NEMO_EXE}          ${WORK_DIR}/ 
     72rsync -avP ${NEMO_EXE}          ${PROD_DIR}/ 
    4173 
    4274for ff in "context_nemo.xml" "domain_def_nemo.xml" "field_def_nemo-oce.xml" "file_def_nemo-oce.xml" "grid_def_nemo.xml" "iodef.xml" "namelist_ref"; do 
    4375    if [ ! -f ${NEMO_EXPREF}/${ff} ]; then echo " Mhhh, ${ff} not found into ${NEMO_EXPREF} !"; exit; fi 
    44     rsync -avPL ${NEMO_EXPREF}/${ff} ${WORK_DIR}/ 
     76    rsync -avPL ${NEMO_EXPREF}/${ff} ${PROD_DIR}/ 
    4577done 
    4678 
    4779# Copy forcing to work directory: 
    48 rsync -avP ${FORC_DIR}/Station_PAPA_50N-145W*.nc ${WORK_DIR}/ 
     80rsync -avP ${DATA_IN_DIR}/Station_PAPA_50N-145W*.nc ${PROD_DIR}/ 
    4981 
    5082for CASE in "ECMWF" "COARE3p6" "NCAR" "ECMWF-noskin" "COARE3p6-noskin"; do 
    … …  
    5890    scase=`echo "${CASE}" | tr '[:upper:]' '[:lower:]'` 
    5991 
    60     rm -f ${WORK_DIR}/namelist_cfg 
    61     rsync -avPL ${NEMO_EXPREF}/namelist_${scase}_cfg ${WORK_DIR}/namelist_cfg 
     92    rm -f ${PROD_DIR}/namelist_cfg 
     93    rsync -avPL ${NEMO_EXPREF}/namelist_${scase}_cfg ${PROD_DIR}/namelist_cfg 
    6294 
    63     cd ${WORK_DIR}/ 
     95    cd ${PROD_DIR}/ 
    6496    echo 
    6597    echo "Launching NEMO !" 
Note: See TracChangeset for help on using the changeset viewer.