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 | !! SVN information |
---|
32 | CHARACTER (LEN = LEN ( "$Author$" )) :: & |
---|
33 | & SVN_Author = "$Author$" |
---|
34 | CHARACTER (LEN = LEN ( "$Date$" )) :: & |
---|
35 | & SVN_Date = "$Date$" |
---|
36 | CHARACTER (LEN = LEN ( "$Revision$")) :: & |
---|
37 | & SVN_Revision = "$Revision$" |
---|
38 | CHARACTER (LEN = LEN ( "$Id$" )) :: & |
---|
39 | & SVN_Id = "$Id$" |
---|
40 | CHARACTER (LEN = LEN ( "$HeadURL$" )) :: & |
---|
41 | & SVN_HeadURL = "$HeadURL$" |
---|
42 | |
---|
43 | !! |
---|
44 | !< Initialisation |
---|
45 | WRITE (UNIT=nout, FMT="('-- start interpol')" ) |
---|
46 | CALL MPI_INIT (ierr) |
---|
47 | |
---|
48 | CALL init_wait |
---|
49 | CALL xios_initialize ("interpol", return_comm=comm) |
---|
50 | |
---|
51 | CALL MPI_COMM_RANK (comm, rank, ierr) |
---|
52 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi_comm_rank')" ) rank |
---|
53 | !CALL MPI_COMM_SIZE (comm, size, ierr) |
---|
54 | |
---|
55 | !< Read command line |
---|
56 | narg = iargc () |
---|
57 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- narg : ', 1I3)" ) rank, narg |
---|
58 | |
---|
59 | !< Read arguments on command line |
---|
60 | DO ja = 1, narg |
---|
61 | CALL getarg ( ja, cmd_arg ) |
---|
62 | SELECT CASE ( TRIM (cmd_arg) ) |
---|
63 | CASE ( '--mask_src=yes' ) ; l_mask_src = .TRUE. |
---|
64 | CASE ( '--mask_src=no' ) ; l_mask_src = .FALSE. |
---|
65 | CASE ( '--mask_dst=yes' ) ; l_mask_dst = .TRUE. |
---|
66 | CASE ( '--mask_dst=no' ) ; l_mask_dst = .FALSE. |
---|
67 | END SELECT |
---|
68 | END DO |
---|
69 | |
---|
70 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mask_src : ', 1L)" ) rank, l_mask_src |
---|
71 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mask_dst : ', 1L)" ) rank, l_mask_dst |
---|
72 | |
---|
73 | !< Context interpol_read : read masks |
---|
74 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- debut interpol_read')" ) rank |
---|
75 | CALL xios_context_initialize ("interpol_read", comm) |
---|
76 | CALL xios_get_handle ("interpol_read", ctx_hdl) |
---|
77 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- set current context interpol_read')" ) rank |
---|
78 | CALL xios_set_current_context (ctx_hdl) |
---|
79 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- close context definition interpol_read')" ) rank |
---|
80 | CALL xios_close_context_definition () |
---|
81 | |
---|
82 | !< Read characteristics of the source grid |
---|
83 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_src')" ) rank |
---|
84 | CALL xios_get_domain_attr ("domain_src", ni=ni_src, nj=nj_src) |
---|
85 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_src ', 6I9)") rank, ni_src, nj_src |
---|
86 | ALLOCATE ( lon_src (ni_src, nj_src), lat_src (ni_src, nj_src) ) |
---|
87 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src ', 6I9)") rank, SIZE (lon_src), SHAPE (lon_src), SIZE (lat_src), SHAPE (lat_src) |
---|
88 | !! |
---|
89 | ! |
---|
90 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture type src ', 6I9)") rank |
---|
91 | CALL xios_get_domain_attr ("domain_src", TYPE=type_src ) |
---|
92 | SELECT CASE ( TRIM (type_src)) |
---|
93 | CASE ( "rectilinear" ) |
---|
94 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src rectilinear', 6I9)") rank |
---|
95 | CALL xios_get_domain_attr ("domain_src", lonvalue_1d=lon_src(:,1), latvalue_1d=lat_src(1,:) ) |
---|
96 | lon_src (:,:) = SPREAD ( lon_src(:,1), DIM=2, ncopies=nj_src) |
---|
97 | lat_src (:,:) = SPREAD ( lat_src(1,:), DIM=1, ncopies=nj_src) |
---|
98 | CASE default |
---|
99 | IF ( nj_src == 1 ) THEN |
---|
100 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 1D ', 6I9)") rank |
---|
101 | CALL xios_get_domain_attr ("domain_src", lonvalue_1d=lon_src(:,1), latvalue_1d=lat_src(:,1) ) |
---|
102 | ELSE |
---|
103 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 2D ', 6I9)") rank |
---|
104 | CALL xios_get_domain_attr ("domain_src", lonvalue_2d=lon_src(:,:), latvalue_2d=lat_src(:,:) ) |
---|
105 | ENDIF |
---|
106 | END SELECT |
---|
107 | !< Read mask on the source grid |
---|
108 | ALLOCATE ( imask_src (ni_src, nj_src), lmask_src (ni_src, nj_src) ) |
---|
109 | IF ( l_mask_src ) THEN |
---|
110 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_src')" ) rank |
---|
111 | CALL xios_recv_field ("mask_src", imask_src) |
---|
112 | lmask_src = .FALSE. |
---|
113 | WHERE (imask_src>0) lmask_src = .TRUE. |
---|
114 | ELSE |
---|
115 | imask_src (:,:) = 1 ; lmask_src (:,:) = .TRUE. |
---|
116 | ENDIF |
---|
117 | |
---|
118 | !< Read mask on the destination grid |
---|
119 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_dst')" ) rank |
---|
120 | CALL xios_get_domain_attr ("domain_dst", ni=ni_dst, nj=nj_dst) |
---|
121 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_dst ', 6I7)") rank, ni_dst, nj_dst |
---|
122 | ALLOCATE ( imask_dst (ni_dst, nj_dst), lmask_dst (ni_dst, nj_dst) ) |
---|
123 | IF ( l_mask_dst ) THEN |
---|
124 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_dst')" ) rank |
---|
125 | CALL xios_recv_field ("mask_dst", imask_dst) |
---|
126 | lmask_dst = .FALSE. |
---|
127 | WHERE (imask_dst>0) lmask_dst = .TRUE. |
---|
128 | ELSE |
---|
129 | imask_dst (:,:) = 1 ; lmask_dst (:,:) = .TRUE. |
---|
130 | ENDIF |
---|
131 | |
---|
132 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (1)')") rank |
---|
133 | CALL xios_context_finalize () |
---|
134 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (2)')") rank |
---|
135 | |
---|
136 | !< Context interpol run : generates weights, interpolate mask from source to destination |
---|
137 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- debut interpol_run')" ) rank |
---|
138 | CALL xios_context_initialize ("interpol_run", comm) |
---|
139 | CALL xios_get_handle ("interpol_run", ctx_hdl) |
---|
140 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- set context interpol_run')" ) rank |
---|
141 | CALL xios_set_current_context (ctx_hdl) |
---|
142 | |
---|
143 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank |
---|
144 | IF ( l_mask_src ) CALL xios_set_domain_attr ("domain_src", mask_2d=lmask_src) |
---|
145 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank |
---|
146 | IF ( l_mask_dst ) CALL xios_set_domain_attr ("domain_dst", mask_2d=lmask_dst) |
---|
147 | |
---|
148 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- close context definition')" ) rank |
---|
149 | CALL xios_close_context_definition () |
---|
150 | |
---|
151 | CALL xios_update_calendar (1) |
---|
152 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- send field mask_src')" ) rank |
---|
153 | CALL xios_send_field ("mask_src", imask_src) |
---|
154 | |
---|
155 | !!< Creates analytic fields and interpolate |
---|
156 | ALLOCATE ( field_src (ni_src, nj_src) ) |
---|
157 | |
---|
158 | DO jf = 1, 6 |
---|
159 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- working on test case ', 1I2.2)" ) rank, jf |
---|
160 | SELECT CASE ( jf) |
---|
161 | CASE ( 1) ; field_src (:,:) = REAL ( imask_src, kind=rl) |
---|
162 | CASE ( 2) ; field_src (:,:) = SIN ( rad * lat_src(:,:) ) |
---|
163 | CASE ( 3) ; field_src (:,:) = COS ( rad * lat_src(:,:) ) |
---|
164 | CASE ( 4) ; field_src (:,:) = COS ( rad * lat_src(:,:) ) * COS ( rad * lon_src(:,:) ) |
---|
165 | CASE ( 5) ; field_src (:,:) = SIN ( rad * lon_src(:,:) ) |
---|
166 | CASE ( 6) ; field_src (:,:) = SIN ( rad * lon_src(:,:) + rpi/2.0_rl ) |
---|
167 | END SELECT |
---|
168 | WRITE (UNIT=nchar, FMT='("field", 1I2.2, "_src")' ) jf |
---|
169 | CALL xios_send_field ( TRIM(nchar), field_src ) |
---|
170 | END DO |
---|
171 | |
---|
172 | !!< |
---|
173 | |
---|
174 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_run')" ) rank |
---|
175 | CALL xios_context_finalize () |
---|
176 | |
---|
177 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi_comm_free')" ) rank |
---|
178 | CALL MPI_COMM_FREE (comm, ierr) |
---|
179 | |
---|
180 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- xios finalize')" ) rank |
---|
181 | CALL xios_finalize () |
---|
182 | |
---|
183 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi finalize')" ) rank |
---|
184 | CALL MPI_FINALIZE (ierr) |
---|
185 | |
---|
186 | WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fini')" ) rank |
---|
187 | |
---|
188 | END PROGRAM interpol |
---|
189 | |
---|
190 | |
---|
191 | |
---|
192 | |
---|
193 | |
---|