[3613] | 1 | ! -*- Mode: f90 -*- |
---|
| 2 | PROGRAM interpol |
---|
| 3 | !!! |
---|
| 4 | !!! Generates interpolation weights from source (src) grid to destination (dst) grid |
---|
| 5 | !!! Most of the configuration is done by the xml file |
---|
| 6 | !!! |
---|
| 7 | USE xios |
---|
| 8 | USE mod_wait |
---|
| 9 | USE mpi |
---|
| 10 | IMPLICIT NONE |
---|
| 11 | ! INCLUDE "mpif.h" |
---|
| 12 | INTEGER, PARAMETER :: rl = SELECTED_REAL_KIND(15,307) !< Default real precision (double) |
---|
| 13 | INTEGER :: ierr, comm, rank |
---|
| 14 | |
---|
| 15 | TYPE (xios_context) :: ctx_hdl |
---|
| 16 | INTEGER :: ni_src, nj_src !< Dimensions of the source grid |
---|
| 17 | INTEGER :: ni_dst, nj_dst !< Dimensions of the source grid |
---|
| 18 | REAL (kind=rl), ALLOCATABLE :: imask_src (:,:), imask_dst (:,:) |
---|
| 19 | REAL (kind=rl), ALLOCATABLE :: lon_src(:,:), lat_src(:,:), field_src(:,:) |
---|
| 20 | LOGICAL, ALLOCATABLE :: lmask_src (:,:), lmask_dst (:,:) |
---|
| 21 | INTEGER :: nout = 0, jf |
---|
| 22 | CHARACTER (LEN=20) :: nchar, type_src, type_dst |
---|
| 23 | LOGICAL :: l_mask_src = .TRUE. , l_mask_dst = .TRUE. |
---|
| 24 | ! |
---|
| 25 | REAL (kind=rl), PARAMETER :: rpi = ACOS ( -1.0_rl) |
---|
| 26 | REAL (kind=rl), PARAMETER :: rad = rpi / 180.0_rl |
---|
| 27 | ! |
---|
| 28 | INTEGER :: narg, ja !< To handle command line arguments |
---|
| 29 | CHARACTER (LEN=80) :: cmd_arg |
---|
| 30 | !! |
---|
| 31 | !< Initialisation |
---|
| 32 | WRITE (UNIT=nout, FMT="('-- start interpol')" ) |
---|
| 33 | CALL MPI_INIT (ierr) |
---|
| 34 | |
---|
| 35 | CALL init_wait |
---|
| 36 | CALL xios_initialize ("interpol", return_comm=comm) |
---|
| 37 | |
---|
| 38 | CALL MPI_COMM_RANK (comm, rank, ierr) |
---|
| 39 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi_comm_rank')" ) rank |
---|
| 40 | !CALL MPI_COMM_SIZE (comm, size, ierr) |
---|
| 41 | |
---|
| 42 | !< Read command line |
---|
| 43 | narg = iargc () |
---|
| 44 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- narg : ', 1I3)" ) rank, narg |
---|
| 45 | |
---|
| 46 | !< Read arguments on command line |
---|
| 47 | DO ja = 1, narg |
---|
| 48 | CALL getarg ( ja, cmd_arg ) |
---|
| 49 | SELECT CASE ( TRIM (cmd_arg) ) |
---|
| 50 | CASE ( '--mask_src=yes' ) ; l_mask_src = .TRUE. |
---|
| 51 | CASE ( '--mask_src=no' ) ; l_mask_src = .FALSE. |
---|
| 52 | CASE ( '--mask_dst=yes' ) ; l_mask_dst = .TRUE. |
---|
| 53 | CASE ( '--mask_dst=no' ) ; l_mask_dst = .FALSE. |
---|
| 54 | END SELECT |
---|
| 55 | END DO |
---|
| 56 | |
---|
| 57 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mask_src : ', 1L)" ) rank, l_mask_src |
---|
| 58 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mask_dst : ', 1L)" ) rank, l_mask_dst |
---|
| 59 | |
---|
| 60 | !< Context interpol_read : read masks |
---|
| 61 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- debut interpol_read')" ) rank |
---|
| 62 | CALL xios_context_initialize ("interpol_read", comm) |
---|
| 63 | CALL xios_get_handle ("interpol_read", ctx_hdl) |
---|
| 64 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- set current context interpol_read')" ) rank |
---|
| 65 | CALL xios_set_current_context (ctx_hdl) |
---|
| 66 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- close context definition interpol_read')" ) rank |
---|
| 67 | CALL xios_close_context_definition () |
---|
| 68 | |
---|
| 69 | !< Read characteristics of the source grid |
---|
| 70 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_src')" ) rank |
---|
| 71 | CALL xios_get_domain_attr ("domain_src", ni=ni_src, nj=nj_src) |
---|
| 72 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_src ', 6I9)") rank, ni_src, nj_src |
---|
| 73 | ALLOCATE ( lon_src (ni_src, nj_src), lat_src (ni_src, nj_src) ) |
---|
| 74 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src ', 6I9)") rank, SIZE (lon_src), SHAPE (lon_src), SIZE (lat_src), SHAPE (lat_src) |
---|
| 75 | !! |
---|
| 76 | ! |
---|
| 77 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture type src ', 6I9)") rank |
---|
| 78 | CALL xios_get_domain_attr ("domain_src", TYPE=type_src ) |
---|
| 79 | SELECT CASE ( TRIM (type_src)) |
---|
| 80 | CASE ( "rectilinear" ) |
---|
| 81 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src rectilinear', 6I9)") rank |
---|
| 82 | CALL xios_get_domain_attr ("domain_src", lonvalue_1d=lon_src(:,1), latvalue_1d=lat_src(1,:) ) |
---|
| 83 | lon_src (:,:) = SPREAD ( lon_src(:,1), DIM=2, ncopies=nj_src) |
---|
| 84 | lat_src (:,:) = SPREAD ( lat_src(1,:), DIM=1, ncopies=nj_src) |
---|
| 85 | CASE default |
---|
| 86 | IF ( nj_src == 1 ) THEN |
---|
| 87 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 1D ', 6I9)") rank |
---|
| 88 | CALL xios_get_domain_attr ("domain_src", lonvalue_1d=lon_src(:,1), latvalue_1d=lat_src(:,1) ) |
---|
| 89 | ELSE |
---|
| 90 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 2D ', 6I9)") rank |
---|
| 91 | CALL xios_get_domain_attr ("domain_src", lonvalue_2d=lon_src(:,:), latvalue_2d=lat_src(:,:) ) |
---|
| 92 | ENDIF |
---|
| 93 | END SELECT |
---|
| 94 | !< Read mask on the source grid |
---|
| 95 | ALLOCATE ( imask_src (ni_src, nj_src), lmask_src (ni_src, nj_src) ) |
---|
| 96 | IF ( l_mask_src ) THEN |
---|
| 97 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_src')" ) rank |
---|
| 98 | CALL xios_recv_field ("mask_src", imask_src) |
---|
| 99 | lmask_src = .FALSE. |
---|
| 100 | WHERE (imask_src>0) lmask_src = .TRUE. |
---|
| 101 | ELSE |
---|
| 102 | imask_src (:,:) = 1 ; lmask_src (:,:) = .TRUE. |
---|
| 103 | ENDIF |
---|
| 104 | |
---|
| 105 | !< Read mask on the destination grid |
---|
| 106 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_dst')" ) rank |
---|
| 107 | CALL xios_get_domain_attr ("domain_dst", ni=ni_dst, nj=nj_dst) |
---|
| 108 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_dst ', 6I7)") rank, ni_dst, nj_dst |
---|
| 109 | ALLOCATE ( imask_dst (ni_dst, nj_dst), lmask_dst (ni_dst, nj_dst) ) |
---|
| 110 | IF ( l_mask_dst ) THEN |
---|
| 111 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_dst')" ) rank |
---|
| 112 | CALL xios_recv_field ("mask_dst", imask_dst) |
---|
| 113 | lmask_dst = .FALSE. |
---|
| 114 | WHERE (imask_dst>0) lmask_dst = .TRUE. |
---|
| 115 | ELSE |
---|
| 116 | imask_dst (:,:) = 1 ; lmask_dst (:,:) = .TRUE. |
---|
| 117 | ENDIF |
---|
| 118 | |
---|
| 119 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (1)')") rank |
---|
| 120 | CALL xios_context_finalize () |
---|
| 121 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (2)')") rank |
---|
| 122 | |
---|
| 123 | !< Context interpol run : generates weights, interpolate mask from source to destination |
---|
| 124 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- debut interpol_run')" ) rank |
---|
| 125 | CALL xios_context_initialize ("interpol_run", comm) |
---|
| 126 | CALL xios_get_handle ("interpol_run", ctx_hdl) |
---|
| 127 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- set context interpol_run')" ) rank |
---|
| 128 | CALL xios_set_current_context (ctx_hdl) |
---|
| 129 | |
---|
| 130 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank |
---|
| 131 | IF ( l_mask_src ) CALL xios_set_domain_attr ("domain_src", mask_2d=lmask_src) |
---|
| 132 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank |
---|
| 133 | IF ( l_mask_dst ) CALL xios_set_domain_attr ("domain_dst", mask_2d=lmask_dst) |
---|
| 134 | |
---|
| 135 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- close context definition')" ) rank |
---|
| 136 | CALL xios_close_context_definition () |
---|
| 137 | |
---|
| 138 | CALL xios_update_calendar (1) |
---|
| 139 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- send field mask_src')" ) rank |
---|
| 140 | CALL xios_send_field ("mask_src", imask_src) |
---|
| 141 | |
---|
| 142 | !!< Creates analytic fields and interpolate |
---|
| 143 | ALLOCATE ( field_src (ni_src, nj_src) ) |
---|
| 144 | |
---|
| 145 | DO jf = 1, 6 |
---|
| 146 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- working on test case ', 1I2.2)" ) rank, jf |
---|
| 147 | SELECT CASE ( jf) |
---|
| 148 | CASE ( 1) ; field_src (:,:) = REAL ( imask_src, kind=rl) |
---|
| 149 | CASE ( 2) ; field_src (:,:) = SIN ( rad * lat_src(:,:) ) |
---|
| 150 | CASE ( 3) ; field_src (:,:) = COS ( rad * lat_src(:,:) ) |
---|
| 151 | CASE ( 4) ; field_src (:,:) = COS ( rad * lat_src(:,:) ) * COS ( rad * lon_src(:,:) ) |
---|
| 152 | CASE ( 5) ; field_src (:,:) = SIN ( rad * lon_src(:,:) ) |
---|
| 153 | CASE ( 6) ; field_src (:,:) = SIN ( rad * lon_src(:,:) + rpi/2.0_rl ) |
---|
| 154 | END SELECT |
---|
| 155 | WRITE (UNIT=nchar, FMT='("field", 1I2.2, "_src")' ) jf |
---|
| 156 | CALL xios_send_field ( TRIM(nchar), field_src ) |
---|
| 157 | END DO |
---|
| 158 | |
---|
| 159 | !!< |
---|
| 160 | |
---|
| 161 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_run')" ) rank |
---|
| 162 | CALL xios_context_finalize () |
---|
| 163 | |
---|
| 164 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi_comm_free')" ) rank |
---|
| 165 | CALL MPI_COMM_FREE (comm, ierr) |
---|
| 166 | |
---|
| 167 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- xios finalize')" ) rank |
---|
| 168 | CALL xios_finalize () |
---|
| 169 | |
---|
| 170 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi finalize')" ) rank |
---|
| 171 | CALL MPI_FINALIZE (ierr) |
---|
| 172 | |
---|
| 173 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fini')" ) rank |
---|
| 174 | |
---|
| 175 | END PROGRAM interpol |
---|
| 176 | |
---|
| 177 | |
---|
| 178 | |
---|
| 179 | |
---|
| 180 | |
---|