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

Changeset 12603


Ignore:
Timestamp:
2020-03-25T16:20:25+01:00 (3 years ago)
Author:
orioltp
Message:

Adding several interfaces to work with both single and double precision

Location:
NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE
Files:
27 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/FLO/floblk.F90

    r12546 r12603  
    175175            zgidfl(jfl) = float(iioutfl(jfl) - iiinfl(jfl)) 
    176176            IF( zufl(jfl)*zuoutfl <= 0. ) THEN 
    177                ztxfl(jfl) = 1.E99_wp 
     177               ztxfl(jfl) = HUGE(0.0_wp) 
    178178            ELSE 
    179179               IF( ABS(zudfl(jfl)) >= 1.E-5 ) THEN 
    … …  
    191191            zgjdfl(jfl) = float(ijoutfl(jfl)-ijinfl(jfl)) 
    192192            IF( zvfl(jfl)*zvoutfl <= 0. ) THEN 
    193                ztyfl(jfl) = 1.E99_wp 
     193               ztyfl(jfl) = HUGE(0.0_wp) 
    194194            ELSE 
    195195               IF( ABS(zvdfl(jfl)) >= 1.E-5 ) THEN 
    … …  
    208208               zgkdfl(jfl) = float(ikoutfl(jfl) - ikinfl(jfl)) 
    209209               IF( zwfl(jfl)*zwoutfl <= 0. ) THEN 
    210                   ztzfl(jfl) = 1.E99_wp 
     210                  ztzfl(jfl) = HUGE(0.0_wp) 
    211211               ELSE 
    212212                  IF( ABS(zwdfl(jfl)) >= 1.E-5 ) THEN 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/ICB/icbthm.F90

    r12291 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/IOM/iom.F90

    r12546 r12603  
    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      ! 
    … …  
    15501691   !!                   INTERFACE iom_rstput 
    15511692   !!---------------------------------------------------------------------- 
    1552    SUBROUTINE iom_rp0d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1693   SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    15531694      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    15541695      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    15551696      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    15561697      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1557       REAL(wp)        , INTENT(in)                         ::   pvar     ! written field 
     1698      REAL(sp)        , INTENT(in)                         ::   pvar     ! written field 
    15581699      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    15591700      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    … …  
    15741715            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    15751716               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    1576                CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 
     1717               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = real(pvar, dp) ) 
    15771718            ENDIF 
    15781719         ENDIF 
    15791720      ENDIF 
    1580    END SUBROUTINE iom_rp0d 
    1581  
    1582    SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1721   END SUBROUTINE iom_rp0d_sp 
     1722 
     1723   SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    15831724      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    15841725      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    15851726      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    15861727      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1587       REAL(wp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
     1728      REAL(dp)        , INTENT(in)                         ::   pvar     ! written field 
     1729      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1730      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
     1731      LOGICAL :: llx                ! local xios write flag 
     1732      INTEGER :: ivid   ! variable id 
     1733 
     1734      llx = .FALSE. 
     1735      IF(PRESENT(ldxios)) llx = ldxios 
     1736      IF( llx ) THEN 
     1737#ifdef key_iomput 
     1738      IF( kt == kwrite ) THEN 
     1739          IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 
     1740          CALL xios_send_field(trim(cdvar), pvar) 
     1741      ENDIF 
     1742#endif 
     1743      ELSE 
     1744         IF( kiomid > 0 ) THEN 
     1745            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1746               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1747               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) 
     1748            ENDIF 
     1749         ENDIF 
     1750      ENDIF 
     1751   END SUBROUTINE iom_rp0d_dp 
     1752 
     1753 
     1754   SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1755      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1756      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1757      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1758      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1759      REAL(sp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
    15881760      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    15891761      LOGICAL, OPTIONAL                                    ::   ldxios   ! xios write flag 
    … …  
    16041776            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    16051777               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    1606                CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 
     1778               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = real(pvar, dp) ) 
    16071779            ENDIF 
    16081780         ENDIF 
    16091781      ENDIF 
    1610    END SUBROUTINE iom_rp1d 
    1611  
    1612    SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1782   END SUBROUTINE iom_rp1d_sp 
     1783 
     1784   SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    16131785      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16141786      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    16151787      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    16161788      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1617       REAL(wp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
     1789      REAL(dp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
     1790      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1791      LOGICAL, OPTIONAL                                    ::   ldxios   ! xios write flag 
     1792      LOGICAL :: llx                ! local xios write flag 
     1793      INTEGER :: ivid   ! variable id 
     1794 
     1795      llx = .FALSE. 
     1796      IF(PRESENT(ldxios)) llx = ldxios 
     1797      IF( llx ) THEN 
     1798#ifdef key_iomput 
     1799      IF( kt == kwrite ) THEN 
     1800         IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 
     1801         CALL xios_send_field(trim(cdvar), pvar) 
     1802      ENDIF 
     1803#endif 
     1804      ELSE 
     1805         IF( kiomid > 0 ) THEN 
     1806            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1807               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1808               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) 
     1809            ENDIF 
     1810         ENDIF 
     1811      ENDIF 
     1812   END SUBROUTINE iom_rp1d_dp 
     1813 
     1814 
     1815   SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1816      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1817      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1818      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1819      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1820      REAL(sp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
    16181821      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    16191822      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    … …  
    16341837            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    16351838               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    1636                CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 
     1839               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = real(pvar, dp) ) 
    16371840            ENDIF 
    16381841         ENDIF 
    16391842      ENDIF 
    1640    END SUBROUTINE iom_rp2d 
    1641  
    1642    SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1843   END SUBROUTINE iom_rp2d_sp 
     1844 
     1845   SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
    16431846      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16441847      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    16451848      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
    16461849      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
    1647       REAL(wp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
     1850      REAL(dp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
     1851      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1852      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
     1853      LOGICAL :: llx 
     1854      INTEGER :: ivid   ! variable id 
     1855 
     1856      llx = .FALSE. 
     1857      IF(PRESENT(ldxios)) llx = ldxios 
     1858      IF( llx ) THEN 
     1859#ifdef key_iomput 
     1860      IF( kt == kwrite ) THEN 
     1861         IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 
     1862         CALL xios_send_field(trim(cdvar), pvar) 
     1863      ENDIF 
     1864#endif 
     1865      ELSE 
     1866         IF( kiomid > 0 ) THEN 
     1867            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1868               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1869               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) 
     1870            ENDIF 
     1871         ENDIF 
     1872      ENDIF 
     1873   END SUBROUTINE iom_rp2d_dp 
     1874 
     1875 
     1876   SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1877      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1878      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1879      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1880      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1881      REAL(sp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
    16481882      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    16491883      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    … …  
    16641898            IF( iom_file(kiomid)%nfid > 0 ) THEN 
    16651899               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1900               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = real(pvar, dp) ) 
     1901            ENDIF 
     1902         ENDIF 
     1903      ENDIF 
     1904   END SUBROUTINE iom_rp3d_sp 
     1905 
     1906   SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1907      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
     1908      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
     1909      INTEGER         , INTENT(in)                         ::   kiomid   ! Identifier of the file  
     1910      CHARACTER(len=*), INTENT(in)                         ::   cdvar    ! time axis name 
     1911      REAL(dp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
     1912      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
     1913      LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
     1914      LOGICAL :: llx                 ! local xios write flag 
     1915      INTEGER :: ivid   ! variable id 
     1916 
     1917      llx = .FALSE. 
     1918      IF(PRESENT(ldxios)) llx = ldxios 
     1919      IF( llx ) THEN 
     1920#ifdef key_iomput 
     1921      IF( kt == kwrite ) THEN 
     1922         IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 
     1923         CALL xios_send_field(trim(cdvar), pvar) 
     1924      ENDIF 
     1925#endif 
     1926      ELSE 
     1927         IF( kiomid > 0 ) THEN 
     1928            IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1929               ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
    16661930               CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) 
    16671931            ENDIF 
    16681932         ENDIF 
    16691933      ENDIF 
    1670    END SUBROUTINE iom_rp3d 
     1934   END SUBROUTINE iom_rp3d_dp 
     1935 
    16711936 
    16721937 
    … …  
    17201985   !!                   INTERFACE iom_put 
    17211986   !!---------------------------------------------------------------------- 
    1722    SUBROUTINE iom_p0d( cdname, pfield0d ) 
     1987   SUBROUTINE iom_p0d_sp( cdname, pfield0d ) 
    17231988      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    1724       REAL(wp)        , INTENT(in) ::   pfield0d 
     1989      REAL(sp)        , INTENT(in) ::   pfield0d 
    17251990!!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    17261991#if defined key_iomput 
    … …  
    17311996      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
    17321997#endif 
    1733    END SUBROUTINE iom_p0d 
    1734  
    1735    SUBROUTINE iom_p1d( cdname, pfield1d ) 
     1998   END SUBROUTINE iom_p0d_sp 
     1999 
     2000   SUBROUTINE iom_p0d_dp( cdname, pfield0d ) 
     2001      CHARACTER(LEN=*), INTENT(in) ::   cdname 
     2002      REAL(dp)        , INTENT(in) ::   pfield0d 
     2003!!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     2004#if defined key_iomput 
     2005!!clem      zz(:,:)=pfield0d 
     2006!!clem      CALL xios_send_field(cdname, zz) 
     2007      CALL xios_send_field(cdname, (/pfield0d/))  
     2008#else 
     2009      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
     2010#endif 
     2011   END SUBROUTINE iom_p0d_dp 
     2012 
     2013 
     2014   SUBROUTINE iom_p1d_sp( cdname, pfield1d ) 
    17362015      CHARACTER(LEN=*)          , INTENT(in) ::   cdname 
    1737       REAL(wp),     DIMENSION(:), INTENT(in) ::   pfield1d 
     2016      REAL(sp),     DIMENSION(:), INTENT(in) ::   pfield1d 
    17382017#if defined key_iomput 
    17392018      CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 
    … …  
    17412020      IF( .FALSE. )   WRITE(numout,*) cdname, pfield1d   ! useless test to avoid compilation warnings 
    17422021#endif 
    1743    END SUBROUTINE iom_p1d 
    1744  
    1745    SUBROUTINE iom_p2d( cdname, pfield2d ) 
     2022   END SUBROUTINE iom_p1d_sp 
     2023 
     2024   SUBROUTINE iom_p1d_dp( cdname, pfield1d ) 
     2025      CHARACTER(LEN=*)          , INTENT(in) ::   cdname 
     2026      REAL(dp),     DIMENSION(:), INTENT(in) ::   pfield1d 
     2027#if defined key_iomput 
     2028      CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) 
     2029#else 
     2030      IF( .FALSE. )   WRITE(numout,*) cdname, pfield1d   ! useless test to avoid compilation warnings 
     2031#endif 
     2032   END SUBROUTINE iom_p1d_dp 
     2033 
     2034   SUBROUTINE iom_p2d_sp( cdname, pfield2d ) 
    17462035      CHARACTER(LEN=*)            , INTENT(in) ::   cdname 
    1747       REAL(wp),     DIMENSION(:,:), INTENT(in) ::   pfield2d 
     2036      REAL(sp),     DIMENSION(:,:), INTENT(in) ::   pfield2d 
    17482037#if defined key_iomput 
    17492038      CALL xios_send_field(cdname, pfield2d) 
    … …  
    17512040      IF( .FALSE. )   WRITE(numout,*) cdname, pfield2d   ! useless test to avoid compilation warnings 
    17522041#endif 
    1753    END SUBROUTINE iom_p2d 
    1754  
    1755    SUBROUTINE iom_p3d( cdname, pfield3d ) 
     2042   END SUBROUTINE iom_p2d_sp 
     2043 
     2044   SUBROUTINE iom_p2d_dp( cdname, pfield2d ) 
     2045      CHARACTER(LEN=*)            , INTENT(in) ::   cdname 
     2046      REAL(dp),     DIMENSION(:,:), INTENT(in) ::   pfield2d 
     2047#if defined key_iomput 
     2048      CALL xios_send_field(cdname, pfield2d) 
     2049#else 
     2050      IF( .FALSE. )   WRITE(numout,*) cdname, pfield2d   ! useless test to avoid compilation warnings 
     2051#endif 
     2052   END SUBROUTINE iom_p2d_dp 
     2053 
     2054   SUBROUTINE iom_p3d_sp( cdname, pfield3d ) 
    17562055      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
    1757       REAL(wp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d 
     2056      REAL(sp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d 
    17582057#if defined key_iomput 
    17592058      CALL xios_send_field( cdname, pfield3d ) 
    … …  
    17612060      IF( .FALSE. )   WRITE(numout,*) cdname, pfield3d   ! useless test to avoid compilation warnings 
    17622061#endif 
    1763    END SUBROUTINE iom_p3d 
    1764  
    1765    SUBROUTINE iom_p4d( cdname, pfield4d ) 
     2062   END SUBROUTINE iom_p3d_sp 
     2063 
     2064   SUBROUTINE iom_p3d_dp( cdname, pfield3d ) 
    17662065      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
    1767       REAL(wp),       DIMENSION(:,:,:,:), INTENT(in) ::   pfield4d 
     2066      REAL(dp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d 
     2067#if defined key_iomput 
     2068      CALL xios_send_field( cdname, pfield3d ) 
     2069#else 
     2070      IF( .FALSE. )   WRITE(numout,*) cdname, pfield3d   ! useless test to avoid compilation warnings 
     2071#endif 
     2072   END SUBROUTINE iom_p3d_dp 
     2073 
     2074   SUBROUTINE iom_p4d_sp( cdname, pfield4d ) 
     2075      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
     2076      REAL(sp),       DIMENSION(:,:,:,:), INTENT(in) ::   pfield4d 
    17682077#if defined key_iomput 
    17692078      CALL xios_send_field(cdname, pfield4d) 
    … …  
    17712080      IF( .FALSE. )   WRITE(numout,*) cdname, pfield4d   ! useless test to avoid compilation warnings 
    17722081#endif 
    1773    END SUBROUTINE iom_p4d 
    1774  
     2082   END SUBROUTINE iom_p4d_sp 
     2083 
     2084   SUBROUTINE iom_p4d_dp( cdname, pfield4d ) 
     2085      CHARACTER(LEN=*)                , INTENT(in) ::   cdname 
     2086      REAL(dp),       DIMENSION(:,:,:,:), INTENT(in) ::   pfield4d 
     2087#if defined key_iomput 
     2088      CALL xios_send_field(cdname, pfield4d) 
     2089#else 
     2090      IF( .FALSE. )   WRITE(numout,*) cdname, pfield4d   ! useless test to avoid compilation warnings 
     2091#endif 
     2092   END SUBROUTINE iom_p4d_dp 
    17752093 
    17762094#if defined key_iomput 
    … …  
    17882106      INTEGER                 , OPTIONAL, INTENT(in) ::   data_dim, data_ibegin, data_ni, data_jbegin, data_nj 
    17892107      INTEGER                 , OPTIONAL, INTENT(in) ::   nvertex 
    1790       REAL(wp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    1791       REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
     2108      REAL(dp), DIMENSION(:)  , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
     2109      REAL(dp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
    17922110      LOGICAL , DIMENSION(:)  , OPTIONAL, INTENT(in) ::   mask 
    17932111      !!---------------------------------------------------------------------- 
    … …  
    18522170      !!---------------------------------------------------------------------- 
    18532171      IF( PRESENT(paxis) ) THEN 
    1854          IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis ) 
    1855          IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 
    1856       ENDIF 
    1857       IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
    1858       IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) 
     2172         IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 
     2173         IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=real(paxis, dp) ) 
     2174      ENDIF 
     2175      IF( PRESENT(bounds) ) THEN 
     2176         IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=real(bounds, dp) ) 
     2177         IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, bounds=real(bounds, dp) ) 
     2178      ELSE 
     2179         IF( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid) 
     2180         IF( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid) 
     2181      END IF 
    18592182      CALL xios_solve_inheritance() 
    18602183   END SUBROUTINE iom_set_axis_attr 
    … …  
    19752298!don't define lon and lat for restart reading context.  
    19762299      IF ( .NOT.ldrxios ) & 
    1977          CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   & 
    1978          &                                     latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     2300         CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = real(RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), dp),   & 
     2301         &                                     latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp ) )   
    19792302      ! 
    19802303      IF ( ln_mskland .AND. (.NOT.ldxios) ) THEN 
    … …  
    20912414      ENDIF 
    20922415      ! 
    2093       CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)),           & 
    2094           &                                    bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), nvertex=4 ) 
     2416      CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), dp),           & 
     2417          &                                    bounds_lon =real( RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), dp), nvertex=4 ) 
    20952418      ! 
    20962419      DEALLOCATE( z_bnds, z_fld, z_rot )  
    … …  
    21202443      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
    21212444      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    2122       CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
    2123          &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     2445      CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp),   & 
     2446         &                             latvalue = real(RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)),dp))   
    21242447      CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 
    21252448      ! 
    … …  
    21362459      !! 
    21372460      !!---------------------------------------------------------------------- 
    2138       REAL(wp), DIMENSION(1)   ::   zz = 1. 
     2461      REAL(dp), DIMENSION(1)   ::   zz = 1. 
    21392462      !!---------------------------------------------------------------------- 
    21402463      ! 
    … …  
    24822805      CHARACTER(LEN=*), INTENT(in ) ::   cdname 
    24832806      REAL(wp)        , INTENT(out) ::   pmiss_val    
     2807      REAL(dp)                      ::   ztmp_pmiss_val    
    24842808#if defined key_iomput 
    24852809      ! get missing value 
    2486       CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 
     2810      CALL xios_get_field_attr( cdname, default_value = ztmp_pmiss_val ) 
     2811      pmiss_val = ztmp_pmiss_val 
    24872812#else 
    24882813      IF( .FALSE. )   WRITE(numout,*) cdname, pmiss_val   ! useless test to avoid compilation warnings 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/IOM/iom_nf90.F90

    r12377 r12603  
    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 
    … …  
    273274   !!---------------------------------------------------------------------- 
    274275 
    275    SUBROUTINE iom_nf90_g0d( kiomid, kvid, pvar, kstart ) 
     276   SUBROUTINE iom_nf90_g0d_sp( kiomid, kvid, pvar, kstart ) 
    276277      !!----------------------------------------------------------------------- 
    277278      !!                  ***  ROUTINE  iom_nf90_g0d  *** 
    … …  
    281282      INTEGER ,               INTENT(in   )            ::   kiomid   ! Identifier of the file 
    282283      INTEGER ,               INTENT(in   )            ::   kvid     ! variable id 
    283       REAL(wp),               INTENT(  out)            ::   pvar     ! read field 
     284      REAL(sp),               INTENT(  out)            ::   pvar     ! read field 
    284285      INTEGER , DIMENSION(1), INTENT(in   ), OPTIONAL  ::   kstart   ! start position of the reading in each axis 
    285286      ! 
    … …  
    288289      clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 
    289290      CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 
    290    END SUBROUTINE iom_nf90_g0d 
    291  
    292  
    293    SUBROUTINE iom_nf90_g123d( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2,   & 
     291   END SUBROUTINE iom_nf90_g0d_sp 
     292 
     293   SUBROUTINE iom_nf90_g0d_dp( kiomid, kvid, pvar, kstart ) 
     294      !!----------------------------------------------------------------------- 
     295      !!                  ***  ROUTINE  iom_nf90_g0d  *** 
     296      !! 
     297      !! ** Purpose : read a scalar with NF90 
     298      !!----------------------------------------------------------------------- 
     299      INTEGER ,               INTENT(in   )            ::   kiomid   ! Identifier of the file 
     300      INTEGER ,               INTENT(in   )            ::   kvid     ! variable id 
     301      REAL(dp),               INTENT(  out)            ::   pvar     ! read field 
     302      INTEGER , DIMENSION(1), INTENT(in   ), OPTIONAL  ::   kstart   ! start position of the reading in each axis 
     303      ! 
     304      CHARACTER(LEN=100)      ::   clinfo   ! info character 
     305      !--------------------------------------------------------------------- 
     306      clinfo = 'iom_nf90_g0d , file: '//TRIM(iom_file(kiomid)%name)//', var: '//TRIM(iom_file(kiomid)%cn_var(kvid)) 
     307      CALL iom_nf90_check(NF90_GET_VAR(iom_file(kiomid)%nfid, iom_file(kiomid)%nvid(kvid), pvar, start = kstart), clinfo ) 
     308   END SUBROUTINE iom_nf90_g0d_dp 
     309 
     310   SUBROUTINE iom_nf90_g123d_dp( kiomid, kvid, knbdim, kstart, kcount, kx1, kx2, ky1, ky2,   & 
    294311         &                    pv_r1d, pv_r2d, pv_r3d ) 
    295312      !!----------------------------------------------------------------------- 
    … …  
    306323      INTEGER , DIMENSION(:)     , INTENT(in   )           ::   kcount    ! number of points to be read in each axis 
    307324      INTEGER ,                    INTENT(in   )           ::   kx1, kx2, ky1, ky2   ! subdomain indexes 
    308       REAL(wp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d    ! read field (1D case) 
    309       REAL(wp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d    ! read field (2D case) 
    310       REAL(wp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d    ! read field (3D case) 
     325      REAL(dp), DIMENSION(:)     , INTENT(  out), OPTIONAL ::   pv_r1d    ! read field (1D case) 
     326      REAL(dp), DIMENSION(:,:)   , INTENT(  out), OPTIONAL ::   pv_r2d    ! read field (2D case) 
     327      REAL(dp), DIMENSION(:,:,:) , INTENT(  out), OPTIONAL ::   pv_r3d    ! read field (3D case) 
    311328      ! 
    312329      CHARACTER(LEN=100) ::   clinfo               ! info character 
    … …  
    329346      ENDIF 
    330347      ! 
    331    END SUBROUTINE iom_nf90_g123d 
     348   END SUBROUTINE iom_nf90_g123d_dp 
     349 
    332350 
    333351 
    … …  
    503521   END SUBROUTINE iom_nf90_putatt 
    504522 
    505  
    506    SUBROUTINE iom_nf90_rp0123d( kt, kwrite, kiomid, cdvar , kvid  , ktype,   & 
     523   SUBROUTINE iom_nf90_rp0123d_dp( kt, kwrite, kiomid, cdvar , kvid  , ktype,   & 
    507524         &                                  pv_r0d, pv_r1d, pv_r2d, pv_r3d ) 
    508525      !!-------------------------------------------------------------------- 
    … …  
    517534      INTEGER                     , INTENT(in)           ::   kvid     ! variable id 
    518535      INTEGER                     , INTENT(in), OPTIONAL ::   ktype    ! variable type (default R8) 
    519       REAL(wp)                    , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
    520       REAL(wp), DIMENSION(      :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
    521       REAL(wp), DIMENSION(:, :   ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
    522       REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
     536      REAL(dp)                    , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
     537      REAL(dp), DIMENSION(      :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
     538      REAL(dp), DIMENSION(:, :   ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
     539      REAL(dp), DIMENSION(:, :, :), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
    523540      ! 
    524541      INTEGER               :: idims                ! number of dimension 
    … …  
    720737      ENDIF 
    721738      !      
    722    END SUBROUTINE iom_nf90_rp0123d 
     739   END SUBROUTINE iom_nf90_rp0123d_dp 
    723740 
    724741 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r11536 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lbc_nfd_ext_generic.h90

    r10525 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lbc_nfd_generic.h90

    r10425 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r11536 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lbclnk.F90

    r12377 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lbcnfd.F90

    r11536 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lib_mpp.F90

    r12512 r12603  
    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 
    … …  
    260270 
    261271 
     272   SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req ) 
     273      !!---------------------------------------------------------------------- 
     274      !!                  ***  routine mppsend  *** 
     275      !! 
     276      !! ** Purpose :   Send messag passing array 
     277      !! 
     278      !!---------------------------------------------------------------------- 
     279      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     280      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     281      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     282      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     283      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     284      !! 
     285      INTEGER ::   iflag 
     286      !!---------------------------------------------------------------------- 
     287      ! 
     288#if defined key_mpp_mpi 
     289      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     290#endif 
     291      ! 
     292   END SUBROUTINE mppsend_dp 
     293 
     294 
     295   SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req ) 
     296      !!---------------------------------------------------------------------- 
     297      !!                  ***  routine mppsend  *** 
     298      !! 
     299      !! ** Purpose :   Send messag passing array 
     300      !! 
     301      !!---------------------------------------------------------------------- 
     302      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     303      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess 
     304      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
     305      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
     306      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     307      !! 
     308      INTEGER ::   iflag 
     309      !!---------------------------------------------------------------------- 
     310      ! 
     311#if defined key_mpp_mpi 
     312      CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     313#endif 
     314      ! 
     315   END SUBROUTINE mppsend_sp 
     316 
     317 
    262318   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource ) 
    263319      !!---------------------------------------------------------------------- 
    … …  
    288344   END SUBROUTINE mpprecv 
    289345 
     346   SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource ) 
     347      !!---------------------------------------------------------------------- 
     348      !!                  ***  routine mpprecv  *** 
     349      !! 
     350      !! ** Purpose :   Receive messag passing array 
     351      !! 
     352      !!---------------------------------------------------------------------- 
     353      REAL(dp), INTENT(inout) ::   pmess(*)   ! array of real 
     354      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     355      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     356      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     357      !! 
     358      INTEGER :: istatus(mpi_status_size) 
     359      INTEGER :: iflag 
     360      INTEGER :: use_source 
     361      !!---------------------------------------------------------------------- 
     362      ! 
     363#if defined key_mpp_mpi 
     364      ! If a specific process number has been passed to the receive call, 
     365      ! use that one. Default is to use mpi_any_source 
     366      use_source = mpi_any_source 
     367      IF( PRESENT(ksource) )   use_source = ksource 
     368      ! 
     369      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     370#endif 
     371      ! 
     372   END SUBROUTINE mpprecv_dp 
     373 
     374 
     375   SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource ) 
     376      !!---------------------------------------------------------------------- 
     377      !!                  ***  routine mpprecv  *** 
     378      !! 
     379      !! ** Purpose :   Receive messag passing array 
     380      !! 
     381      !!---------------------------------------------------------------------- 
     382      REAL(sp), INTENT(inout) ::   pmess(*)   ! array of real 
     383      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess 
     384      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message 
     385      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
     386      !! 
     387      INTEGER :: istatus(mpi_status_size) 
     388      INTEGER :: iflag 
     389      INTEGER :: use_source 
     390      !!---------------------------------------------------------------------- 
     391      ! 
     392#if defined key_mpp_mpi 
     393      ! If a specific process number has been passed to the receive call, 
     394      ! use that one. Default is to use mpi_any_source 
     395      use_source = mpi_any_source 
     396      IF( PRESENT(ksource) )   use_source = ksource 
     397      ! 
     398      CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     399#endif 
     400      ! 
     401   END SUBROUTINE mpprecv_sp 
     402 
    290403 
    291404   SUBROUTINE mppgather( ptab, kp, pio ) 
    … …  
    351464      CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    352465      CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    353       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
     466      COMPLEX(dp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    354467      REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    355468      LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    … …  
    359472      INTEGER ::   idvar 
    360473      INTEGER ::   ierr, ilocalcomm 
    361       COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
     474      COMPLEX(dp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    362475      !!---------------------------------------------------------------------- 
    363476#if defined key_mpp_mpi 
    … …  
    432545      INTEGER ::   idvar 
    433546      INTEGER ::   ierr, ilocalcomm 
    434       !!---------------------------------------------------------------------- 
    435 #if defined key_mpp_mpi 
     547      INTEGER ::   MPI_TYPE 
     548      !!---------------------------------------------------------------------- 
     549       
     550#if defined key_mpp_mpi 
     551      if( wp == dp ) then 
     552         MPI_TYPE = MPI_DOUBLE_PRECISION 
     553      else if ( wp == sp ) then 
     554         MPI_TYPE = MPI_REAL 
     555      else 
     556        CALL ctl_stop( "Error defining type, wp is neither dp nor sp" ) 
     557    
     558      end if 
     559 
    436560      ilocalcomm = mpi_comm_oce 
    437561      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    470594# if defined key_mpi2 
    471595      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 
     596      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    474597      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    475598# else 
    476       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     599      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    477600# endif 
    478601#else 
    … …  
    551674#  undef INTEGER_TYPE 
    552675! 
     676   !! 
     677   !!   ----   SINGLE PRECISION VERSIONS 
     678   !! 
     679#  define SINGLE_PRECISION 
    553680#  define REAL_TYPE 
    554681#  define DIM_0d 
    555 #     define ROUTINE_ALLREDUCE           mppmax_real 
     682#     define ROUTINE_ALLREDUCE           mppmax_real_sp 
    556683#     include "mpp_allreduce_generic.h90" 
    557684#     undef ROUTINE_ALLREDUCE 
    558685#  undef DIM_0d 
    559686#  define DIM_1d 
    560 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
     687#     define ROUTINE_ALLREDUCE           mppmax_a_real_sp 
     688#     include "mpp_allreduce_generic.h90" 
     689#     undef ROUTINE_ALLREDUCE 
     690#  undef DIM_1d 
     691#  undef SINGLE_PRECISION 
     692   !! 
     693   !! 
     694   !!   ----   DOUBLE PRECISION VERSIONS 
     695   !! 
     696! 
     697#  define DIM_0d 
     698#     define ROUTINE_ALLREDUCE           mppmax_real_dp 
     699#     include "mpp_allreduce_generic.h90" 
     700#     undef ROUTINE_ALLREDUCE 
     701#  undef DIM_0d 
     702#  define DIM_1d 
     703#     define ROUTINE_ALLREDUCE           mppmax_a_real_dp 
    561704#     include "mpp_allreduce_generic.h90" 
    562705#     undef ROUTINE_ALLREDUCE 
    … …  
    583726#  undef INTEGER_TYPE 
    584727! 
     728   !! 
     729   !!   ----   SINGLE PRECISION VERSIONS 
     730   !! 
     731#  define SINGLE_PRECISION 
    585732#  define REAL_TYPE 
    586733#  define DIM_0d 
    587 #     define ROUTINE_ALLREDUCE           mppmin_real 
     734#     define ROUTINE_ALLREDUCE           mppmin_real_sp 
    588735#     include "mpp_allreduce_generic.h90" 
    589736#     undef ROUTINE_ALLREDUCE 
    590737#  undef DIM_0d 
    591738#  define DIM_1d 
    592 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
     739#     define ROUTINE_ALLREDUCE           mppmin_a_real_sp 
     740#     include "mpp_allreduce_generic.h90" 
     741#     undef ROUTINE_ALLREDUCE 
     742#  undef DIM_1d 
     743#  undef SINGLE_PRECISION 
     744   !! 
     745   !!   ----   DOUBLE PRECISION VERSIONS 
     746   !! 
     747 
     748#  define DIM_0d 
     749#     define ROUTINE_ALLREDUCE           mppmin_real_dp 
     750#     include "mpp_allreduce_generic.h90" 
     751#     undef ROUTINE_ALLREDUCE 
     752#  undef DIM_0d 
     753#  define DIM_1d 
     754#     define ROUTINE_ALLREDUCE           mppmin_a_real_dp 
    593755#     include "mpp_allreduce_generic.h90" 
    594756#     undef ROUTINE_ALLREDUCE 
    … …  
    616778#  undef DIM_1d 
    617779#  undef INTEGER_TYPE 
    618 ! 
     780 
     781   !! 
     782   !!   ----   SINGLE PRECISION VERSIONS 
     783   !! 
     784#  define OPERATION_SUM 
     785#  define SINGLE_PRECISION 
    619786#  define REAL_TYPE 
    620787#  define DIM_0d 
    621 #     define ROUTINE_ALLREDUCE           mppsum_real 
     788#     define ROUTINE_ALLREDUCE           mppsum_real_sp 
    622789#     include "mpp_allreduce_generic.h90" 
    623790#     undef ROUTINE_ALLREDUCE 
    624791#  undef DIM_0d 
    625792#  define DIM_1d 
    626 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
     793#     define ROUTINE_ALLREDUCE           mppsum_a_real_sp 
     794#     include "mpp_allreduce_generic.h90" 
     795#     undef ROUTINE_ALLREDUCE 
     796#  undef DIM_1d 
     797#  undef REAL_TYPE 
     798#  undef OPERATION_SUM 
     799 
     800#  undef SINGLE_PRECISION 
     801 
     802   !! 
     803   !!   ----   DOUBLE PRECISION VERSIONS 
     804   !! 
     805#  define OPERATION_SUM 
     806#  define REAL_TYPE 
     807#  define DIM_0d 
     808#     define ROUTINE_ALLREDUCE           mppsum_real_dp 
     809#     include "mpp_allreduce_generic.h90" 
     810#     undef ROUTINE_ALLREDUCE 
     811#  undef DIM_0d 
     812#  define DIM_1d 
     813#     define ROUTINE_ALLREDUCE           mppsum_a_real_dp 
    627814#     include "mpp_allreduce_generic.h90" 
    628815#     undef ROUTINE_ALLREDUCE 
    … …  
    651838   !!---------------------------------------------------------------------- 
    652839   !! 
     840   !! 
     841   !!   ----   SINGLE PRECISION VERSIONS 
     842   !! 
     843#  define SINGLE_PRECISION 
    653844#  define OPERATION_MINLOC 
    654845#  define DIM_2d 
    655 #     define ROUTINE_LOC           mpp_minloc2d 
     846#     define ROUTINE_LOC           mpp_minloc2d_sp 
    656847#     include "mpp_loc_generic.h90" 
    657848#     undef ROUTINE_LOC 
    658849#  undef DIM_2d 
    659850#  define DIM_3d 
    660 #     define ROUTINE_LOC           mpp_minloc3d 
     851#     define ROUTINE_LOC           mpp_minloc3d_sp 
    661852#     include "mpp_loc_generic.h90" 
    662853#     undef ROUTINE_LOC 
    … …  
    666857#  define OPERATION_MAXLOC 
    667858#  define DIM_2d 
    668 #     define ROUTINE_LOC           mpp_maxloc2d 
     859#     define ROUTINE_LOC           mpp_maxloc2d_sp 
    669860#     include "mpp_loc_generic.h90" 
    670861#     undef ROUTINE_LOC 
    671862#  undef DIM_2d 
    672863#  define DIM_3d 
    673 #     define ROUTINE_LOC           mpp_maxloc3d 
     864#     define ROUTINE_LOC           mpp_maxloc3d_sp 
    674865#     include "mpp_loc_generic.h90" 
    675866#     undef ROUTINE_LOC 
    676867#  undef DIM_3d 
    677868#  undef OPERATION_MAXLOC 
     869#  undef SINGLE_PRECISION 
     870   !! 
     871   !!   ----   DOUBLE PRECISION VERSIONS 
     872   !! 
     873#  define OPERATION_MINLOC 
     874#  define DIM_2d 
     875#     define ROUTINE_LOC           mpp_minloc2d_dp 
     876#     include "mpp_loc_generic.h90" 
     877#     undef ROUTINE_LOC 
     878#  undef DIM_2d 
     879#  define DIM_3d 
     880#     define ROUTINE_LOC           mpp_minloc3d_dp 
     881#     include "mpp_loc_generic.h90" 
     882#     undef ROUTINE_LOC 
     883#  undef DIM_3d 
     884#  undef OPERATION_MINLOC 
     885 
     886#  define OPERATION_MAXLOC 
     887#  define DIM_2d 
     888#     define ROUTINE_LOC           mpp_maxloc2d_dp 
     889#     include "mpp_loc_generic.h90" 
     890#     undef ROUTINE_LOC 
     891#  undef DIM_2d 
     892#  define DIM_3d 
     893#     define ROUTINE_LOC           mpp_maxloc3d_dp 
     894#     include "mpp_loc_generic.h90" 
     895#     undef ROUTINE_LOC 
     896#  undef DIM_3d 
     897#  undef OPERATION_MAXLOC 
     898 
    678899 
    679900   SUBROUTINE mppsync() 
    … …  
    9041125      !!--------------------------------------------------------------------- 
    9051126      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 
     1127      COMPLEX(dp), DIMENSION(ilen), INTENT(in)    ::   ydda 
     1128      COMPLEX(dp), DIMENSION(ilen), INTENT(inout) ::   yddb 
     1129      ! 
     1130      REAL(dp) :: zerr, zt1, zt2    ! local work variables 
    9101131      INTEGER  :: ji, ztmp           ! local scalar 
    9111132      !!--------------------------------------------------------------------- 
    … …  
    10601281    LOGICAL,           INTENT(IN) :: ld_tic 
    10611282    LOGICAL, OPTIONAL, INTENT(IN) :: ld_global 
    1062     REAL(wp), DIMENSION(2), SAVE :: tic_wt 
    1063     REAL(wp),               SAVE :: tic_ct = 0._wp 
     1283    REAL(dp), DIMENSION(2), SAVE :: tic_wt 
     1284    REAL(dp),               SAVE :: tic_ct = 0._dp 
    10641285    INTEGER :: ii 
    10651286#if defined key_mpp_mpi 
    … …  
    10741295    IF ( ld_tic ) THEN 
    10751296       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 
     1297       IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct   ! cumulate count tac->tic 
    10771298    ELSE 
    10781299       waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii)              ! cumulate count tic->tac 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/mpp_allreduce_generic.h90

    r12546 r12603  
    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(wp)       , INTENT(inout) ::   ARRAY_IN(i) 
    14 #      define TMP_TYPE(i)      COMPLEX(wp)       , 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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/mpp_lnk_generic.h90

    r11536 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/mpp_loc_generic.h90

    r10716 r12603  
    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# if defined key_mpp_mpi 
    … …  
    3644      INTEGER  ::   ierror, ii, idim 
    3745      INTEGER  ::   index0 
    38       REAL(wp) ::   zmin     ! local minimum 
     46      REAL(PRECISION) ::   zmin     ! local minimum 
    3947      INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs 
    40       REAL(wp), DIMENSION(2,1) ::   zain, zaout 
     48      REAL(dp), DIMENSION(2,1) ::   zain, zaout 
    4149      !!----------------------------------------------------------------------- 
    4250      ! 
    … …  
    99107   END SUBROUTINE ROUTINE_LOC 
    100108 
     109 
     110#undef PRECISION 
    101111#undef ARRAY_TYPE 
    102112#undef MAX_TYPE 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/mpp_nfd_generic.h90

    r11536 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/OBS/ddatetoymdhms.h90

    r10068 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/OBS/obs_read_prof.F90

    r10068 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/OBS/obs_read_surf.F90

    r10069 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/SBC/sbcfwb.F90

    r12546 r12603  
    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      ! 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/STO/stopar.F90

    r12377 r12603  
    686686      INTEGER  :: jsto, jseed 
    687687      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type 
    688       REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart) 
     688      REAL(KIND=dp)       ::   zrseed(4)           ! RNG seeds in double-precision (with same bits to save in restart) 
    689689      CHARACTER(LEN=9)    ::   clsto2d='sto2d_000' ! stochastic parameter variable name 
    690690      CHARACTER(LEN=9)    ::   clsto3d='sto3d_000' ! stochastic parameter variable name 
    … …  
    744744      INTEGER  :: jsto, jseed 
    745745      INTEGER(KIND=8)     ::   ziseed(4)           ! RNG seeds in integer type 
    746       REAL(KIND=8)        ::   zrseed(4)           ! RNG seeds in real type (with same bits to save in restart) 
     746      REAL(KIND=dp)       ::   zrseed(4)           ! RNG seeds in double-precision (with same bits to save in restart) 
    747747      CHARACTER(LEN=20)   ::   clkt                ! ocean time-step defined as a character 
    748748      CHARACTER(LEN=50)   ::   clname              ! restart file name 
    … …  
    827827      !! 
    828828      INTEGER  :: ji, jj 
    829       REAL(KIND=8) :: gran   ! Gaussian random number (forced KIND=8 as in kiss_gaussian) 
     829      REAL(wp) :: gran   ! Gaussian random number (forced KIND=8 as in kiss_gaussian) 
    830830 
    831831      DO_2D_11_11 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/TRA/traadv_fct.F90

    r12546 r12603  
    374374      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    375375      INTEGER  ::   ikm1         ! local integer 
    376       REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn    ! local scalars 
    377       REAL(wp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
    378       REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 
    379       !!---------------------------------------------------------------------- 
    380       ! 
    381       zbig  = 1.e+40_wp 
    382       zrtrn = 1.e-15_wp 
    383       zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp 
     376      REAL(dp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn    ! local scalars 
     377      REAL(dp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
     378      REAL(dp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 
     379      !!---------------------------------------------------------------------- 
     380      ! 
     381      zbig  = 1.e+40_dp 
     382      zrtrn = 1.e-15_dp 
     383      zbetup(:,:,:) = 0._dp   ;   zbetdo(:,:,:) = 0._dp 
    384384 
    385385      ! Search local extrema 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/TRA/traadv_ubs.F90

    r12546 r12603  
    270270      !!---------------------------------------------------------------------- 
    271271      ! 
    272       zbig  = 1.e+40_wp 
     272      zbig  = 1.e+38_wp 
    273273      zrtrn = 1.e-15_wp 
    274274      zbetup(:,:,:) = 0._wp   ;   zbetdo(:,:,:) = 0._wp 

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/ZDF/zdfddm.F90

    r12377 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/lib_fortran.F90

    r12546 r12603  
    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 
    … …  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/lib_fortran_generic.h90

    r10425 r12603  
    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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/nemogcm.F90

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

  • NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/par_kind.F90

    r10068 r12603  
    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 ** 
Note: See TracChangeset for help on using the changeset viewer.