Ignore:
Timestamp:
11/27/18 17:08:31 (5 years ago)
Author:
omamce
Message:

O.M. : include areas correction

File:
1 edited

Legend:

Unmodified
Added
Removed

  • TOOLS/MOSAIX/src/MOSAIX/interpol.f90

    r3940 r4153  
    1616   INTEGER :: ni_src, nj_src !< Dimensions of the source grid 
    1717   INTEGER :: ni_dst, nj_dst !< Dimensions of the source grid 
    18    REAL (kind=rl), ALLOCATABLE :: imask_src (:,:), imask_dst (:,:) 
     18   REAL (kind=rl), ALLOCATABLE :: imask_src (:,:), imask_dst (:,:), area_src(:,:), area_dst(:,:) 
    1919   REAL (kind=rl), ALLOCATABLE :: lon_src(:,:), lat_src(:,:), field_src(:,:) 
    2020   LOGICAL, ALLOCATABLE :: lmask_src (:,:), lmask_dst (:,:) 
    2121   INTEGER :: nout = 0, jf 
    2222   CHARACTER (LEN=20) :: nchar, type_src, type_dst 
    23    LOGICAL :: l_mask_src = .TRUE. , l_mask_dst = .TRUE. 
     23   LOGICAL :: l_mask_src = .TRUE. , l_mask_dst = .TRUE., l_use_area = .FALSE. 
    2424   ! 
    2525   REAL (kind=rl), PARAMETER :: rpi = ACOS ( -1.0_rl) 
    … …  
    6464      CALL getarg ( ja, cmd_arg ) 
    6565      SELECT CASE ( TRIM (cmd_arg) ) 
    66       CASE ( '--mask_src=yes' ) ; l_mask_src = .TRUE. 
    67       CASE ( '--mask_src=no'  ) ; l_mask_src = .FALSE. 
    68       CASE ( '--mask_dst=yes' ) ; l_mask_dst = .TRUE. 
    69       CASE ( '--mask_dst=no'  ) ; l_mask_dst = .FALSE. 
     66      CASE ( '--mask_src=true'  ) ; l_mask_src = .TRUE. 
     67      CASE ( '--mask_src=false' ) ; l_mask_src = .FALSE. 
     68      CASE ( '--mask_dst=true'  ) ; l_mask_dst = .TRUE. 
     69      CASE ( '--mask_dst=false' ) ; l_mask_dst = .FALSE. 
     70      CASE ( '--use_area=true'  ) ; l_use_area = .TRUE. 
     71      CASE ( '--use_area=no'    ) ; l_use_area = .FALSE. 
    7072      END SELECT 
    7173   END DO 
    … …  
    7375   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mask_src : ', 1L)" ) rank, l_mask_src 
    7476   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mask_dst : ', 1L)" ) rank, l_mask_dst 
     77   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- use_area : ', 1L)" ) rank, l_use_area 
    7578 
    7679   !< Context interpol_read : read masks 
    77    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- debut interpol_read')" ) rank 
     80   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Starting interpol_read')" ) rank 
    7881   CALL xios_context_initialize  ("interpol_read", comm) 
    7982   CALL xios_get_handle          ("interpol_read", ctx_hdl) 
    80    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- set current context interpol_read')" ) rank 
     83   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Set current context interpol_read')" ) rank 
    8184   CALL xios_set_current_context (ctx_hdl) 
    82    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- close context definition interpol_read')" ) rank 
     85   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Close context definition interpol_read')" ) rank 
    8386   CALL xios_close_context_definition () 
    8487 
    8588   !< Read characteristics of the source grid 
    86    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_src')" ) rank 
     89   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading domain_src')" ) rank 
    8790   CALL xios_get_domain_attr ("domain_src", ni=ni_src, nj=nj_src) 
    88    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_src ', 6I9)") rank, ni_src, nj_src 
     91   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading domain_src ', 6I9)") rank, ni_src, nj_src 
    8992   ALLOCATE ( lon_src (ni_src, nj_src), lat_src (ni_src, nj_src) ) 
    90    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src ', 6I9)") rank, SIZE (lon_src), & 
     93   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading lon lat src ', 6I9)") rank, SIZE (lon_src), & 
    9194      &        SHAPE (lon_src), SIZE (lat_src), SHAPE (lat_src) 
    9295   !! 
    9396   ! 
    94    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture type src ', 6I9)") rank 
     97   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading type src ', 6I9)") rank 
    9598   CALL xios_get_domain_attr ("domain_src", TYPE=type_src ) 
    9699   SELECT CASE ( TRIM (type_src)) 
    97100   CASE ( "rectilinear" ) 
    98       WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src rectilinear', 6I9)") rank 
     101      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading lon lat src rectilinear', 6I9)") rank 
    99102      CALL xios_get_domain_attr ("domain_src", lonvalue_1d=lon_src(:,1), latvalue_1d=lat_src(1,:) ) 
    100103      lon_src (:,:) = SPREAD ( lon_src(:,1), DIM=2, ncopies=nj_src) 
    … …  
    102105   CASE default 
    103106      IF ( nj_src == 1 .AND. ni_src==1) THEN 
    104          WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 2D ', 6I9)") rank 
     107         WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading lon lat src 2D ', 6I9)") rank 
    105108         CALL xios_get_domain_attr ("domain_src", lonvalue_2d=lon_src(:,:), latvalue_2d=lat_src(:,:) ) 
    106109      ELSE IF ( nj_src == 1 ) THEN 
    107          WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 1D ', 6I9)") rank 
     110         WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading lon lat src 1D ', 6I9)") rank 
    108111         CALL xios_get_domain_attr ("domain_src", lonvalue_1d=lon_src(:,1), latvalue_1d=lat_src(:,1) ) 
    109112      ELSE 
    110          WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 2D ', 6I9)") rank 
     113         WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading lon lat src 2D ', 6I9)") rank 
    111114         CALL xios_get_domain_attr ("domain_src", lonvalue_2d=lon_src(:,:), latvalue_2d=lat_src(:,:) ) 
    112115      ENDIF 
    113116   END SELECT 
     117    
    114118   !< Read mask on the source grid 
    115119   ALLOCATE ( imask_src (ni_src, nj_src), lmask_src (ni_src, nj_src) ) 
    116120   IF ( l_mask_src ) THEN  
    117       WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_src')" ) rank 
     121      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Receive field mask_src')" ) rank 
    118122      CALL xios_recv_field ("mask_src", imask_src) 
    119123      lmask_src = .FALSE. 
    … …  
    122126      imask_src (:,:) = 1 ; lmask_src (:,:) = .TRUE. 
    123127   ENDIF 
    124    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- counting mask_src : ', 1I8)" ) rank, COUNT(lmask_src) 
     128   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Counting mask_src : ', 1I8)" ) rank, COUNT(lmask_src) 
     129 
     130   !< Read area on the source grid 
     131   ALLOCATE ( area_src (ni_src, nj_src) ) 
     132   IF ( l_use_area ) THEN 
     133      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Receive field area_src')" ) rank 
     134      CALL xios_recv_field ("area_src", area_src) 
     135   ELSE 
     136      area_src (:,:) = 1 
     137   ENDIF 
     138   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Sum area_src : ', 2E15.3)" ) rank, SUM(area_src) !, SUM(area_src, mask=lmask_src) 
    125139    
    126140   !< Read mask on the destination grid 
    127    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_dst')" ) rank 
     141   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading domain_dst')" ) rank 
    128142   CALL xios_get_domain_attr ("domain_dst", ni=ni_dst, nj=nj_dst) 
    129    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_dst ', 6I7)") rank, ni_dst, nj_dst 
     143   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Reading domain_dst ', 6I7)") rank, ni_dst, nj_dst 
    130144   ALLOCATE ( imask_dst (ni_dst, nj_dst), lmask_dst (ni_dst, nj_dst) ) 
    131145   IF ( l_mask_dst ) THEN 
    132       WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_dst')" ) rank  
     146      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Receive field mask_dst')" ) rank  
    133147      CALL xios_recv_field ("mask_dst", imask_dst) 
    134148      lmask_dst = .FALSE. 
    … …  
    139153   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- counting mask_dst : ', 1I8)" ) rank, COUNT(lmask_dst) 
    140154 
    141    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (1)')") rank 
     155   !< Read area on the destination grid 
     156   ALLOCATE ( area_dst (ni_dst, nj_dst) ) 
     157   IF ( l_use_area ) THEN 
     158      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field area_dst')" ) rank  
     159      CALL xios_recv_field ("area_dst", area_dst) 
     160   ELSE 
     161      area_dst (:,:) = 1.0 
     162   ENDIF 
     163   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Counting mask_dst : ', 2E15.3)" ) rank, SUM(area_dst) !, SUM(area_dst,mask=lmask_dst) 
     164 
     165   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- End interpol_read (1)')") rank 
    142166   CALL xios_context_finalize () 
    143    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (2)')") rank 
     167   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- End interpol_read (2)')") rank 
    144168    
    145169   !< Context interpol run : generates weights, interpolate mask from source to destination 
    146    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- debut interpol_run')" ) rank 
     170   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Starting interpol_run')" ) rank 
    147171   CALL xios_context_initialize  ("interpol_run", comm) 
    148172   CALL xios_get_handle          ("interpol_run", ctx_hdl) 
    149    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- set context interpol_run')" ) rank 
     173   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Set context interpol_run')" ) rank 
    150174   CALL xios_set_current_context (ctx_hdl) 
    151175 
    152    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank 
     176   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Get attributes domain_src')" ) rank 
    153177   IF ( l_mask_src ) CALL xios_set_domain_attr ("domain_src", mask_2d=lmask_src) 
     178   IF ( l_use_area ) CALL xios_set_domain_attr ("domain_src", area   =area_src ) 
     179   !CALL xios_set_domain_attr ("domain_src", radius= 6371229.0 ) 
    154180   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank 
    155181   IF ( l_mask_dst ) CALL xios_set_domain_attr ("domain_dst", mask_2d=lmask_dst) 
    156  
    157    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- close context definition')" ) rank 
     182   IF ( l_use_area ) CALL xios_set_domain_attr ("domain_dst", area   =area_dst ) 
     183   !CALL xios_set_domain_attr ("domain_dst", radius= 6371229.0 ) 
     184    
     185   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Close context definition')" ) rank 
    158186   CALL xios_close_context_definition () 
    159187 
    160188   CALL xios_update_calendar (1) 
    161    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- send field mask_src')" ) rank 
     189   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Send field mask_src')" ) rank 
    162190   CALL xios_send_field ("mask_src", imask_src) 
    163191 
    … …  
    166194 
    167195   DO jf = 1, 6 
    168       WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- working on test case ', 1I2.2)" ) rank, jf 
     196      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- Working on test case ', 1I2.2)" ) rank, jf 
    169197      SELECT CASE ( jf) 
    170198      CASE ( 1) ; field_src (:,:) = REAL ( imask_src, kind=rl) 
    … …  
    181209   !!< 
    182210    
    183    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_run')" ) rank 
     211   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- End interpol_run')" ) rank 
    184212   CALL xios_context_finalize () 
    185213 
    … …  
    193221   CALL MPI_FINALIZE (ierr) 
    194222 
    195    WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fini')" ) rank 
     223   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- The end')" ) rank 
    196224 
    197225END PROGRAM interpol 
Note: See TracChangeset for help on using the changeset viewer.