source: TOOLS/MOSAIX/src/MOSAIX/interpol.f90 @ 3733

Last change on this file since 3733 was 3733, checked in by omamce, 6 years ago

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