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

Last change on this file since 3940 was 3940, checked in by lbedidi, 3 years ago
  1. Bedidi: fixing 0D case
  • Property svn:keywords set to Date Revision HeadURL Author Id
File size: 8.4 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 .AND. ni_src==1) THEN
104         WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 2D ', 6I9)") rank
105         CALL xios_get_domain_attr ("domain_src", lonvalue_2d=lon_src(:,:), latvalue_2d=lat_src(:,:) )
106      ELSE IF ( nj_src == 1 ) THEN
107         WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 1D ', 6I9)") rank
108         CALL xios_get_domain_attr ("domain_src", lonvalue_1d=lon_src(:,1), latvalue_1d=lat_src(:,1) )
109      ELSE
110         WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture lon lat src 2D ', 6I9)") rank
111         CALL xios_get_domain_attr ("domain_src", lonvalue_2d=lon_src(:,:), latvalue_2d=lat_src(:,:) )
112      ENDIF
113   END SELECT
114   !< Read mask on the source grid
115   ALLOCATE ( imask_src (ni_src, nj_src), lmask_src (ni_src, nj_src) )
116   IF ( l_mask_src ) THEN
117      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_src')" ) rank
118      CALL xios_recv_field ("mask_src", imask_src)
119      lmask_src = .FALSE.
120      WHERE (imask_src > 0.5 ) lmask_src = .TRUE.
121   ELSE
122      imask_src (:,:) = 1 ; lmask_src (:,:) = .TRUE.
123   ENDIF
124   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- counting mask_src : ', 1I8)" ) rank, COUNT(lmask_src)
125   
126   !< Read mask on the destination grid
127   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- lecture domain_dst')" ) rank
128   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
130   ALLOCATE ( imask_dst (ni_dst, nj_dst), lmask_dst (ni_dst, nj_dst) )
131   IF ( l_mask_dst ) THEN
132      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- receive field mask_dst')" ) rank 
133      CALL xios_recv_field ("mask_dst", imask_dst)
134      lmask_dst = .FALSE.
135      WHERE (imask_dst > 0.5) lmask_dst = .TRUE.
136   ELSE
137      imask_dst (:,:) = 1 ; lmask_dst (:,:) = .TRUE.
138   ENDIF
139   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- counting mask_dst : ', 1I8)" ) rank, COUNT(lmask_dst)
140
141   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (1)')") rank
142   CALL xios_context_finalize ()
143   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_read (2)')") rank
144   
145   !< Context interpol run : generates weights, interpolate mask from source to destination
146   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- debut interpol_run')" ) rank
147   CALL xios_context_initialize  ("interpol_run", comm)
148   CALL xios_get_handle          ("interpol_run", ctx_hdl)
149   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- set context interpol_run')" ) rank
150   CALL xios_set_current_context (ctx_hdl)
151
152   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank
153   IF ( l_mask_src ) CALL xios_set_domain_attr ("domain_src", mask_2d=lmask_src)
154   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- get attributes domain_src')" ) rank
155   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
158   CALL xios_close_context_definition ()
159
160   CALL xios_update_calendar (1)
161   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- send field mask_src')" ) rank
162   CALL xios_send_field ("mask_src", imask_src)
163
164   !!< Creates analytic fields and interpolate
165   ALLOCATE ( field_src (ni_src, nj_src) )
166
167   DO jf = 1, 6
168      WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- working on test case ', 1I2.2)" ) rank, jf
169      SELECT CASE ( jf)
170      CASE ( 1) ; field_src (:,:) = REAL ( imask_src, kind=rl)
171      CASE ( 2) ; field_src (:,:) = SIN ( rad * lat_src(:,:) )
172      CASE ( 3) ; field_src (:,:) = COS ( rad * lat_src(:,:) )
173      CASE ( 4) ; field_src (:,:) = COS ( rad * lat_src(:,:) ) * COS ( rad * lon_src(:,:) )
174      CASE ( 5) ; field_src (:,:) = SIN ( rad * lon_src(:,:) )
175      CASE ( 6) ; field_src (:,:) = SIN ( rad * lon_src(:,:) + rpi/2.0_rl )
176      END SELECT
177      WRITE (UNIT=nchar, FMT='("field", 1I2.2, "_src")' ) jf
178      CALL xios_send_field ( TRIM(nchar), field_src )
179   END DO
180   
181   !!<
182   
183   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fin interpol_run')" ) rank
184   CALL xios_context_finalize ()
185
186   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi_comm_free')" ) rank
187   CALL MPI_COMM_FREE (comm, ierr)
188
189   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- xios finalize')" ) rank
190   CALL xios_finalize ()
191
192   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- mpi finalize')" ) rank
193   CALL MPI_FINALIZE (ierr)
194
195   WRITE (UNIT=nout, FMT="('-- ', 1I4.4, ' -- fini')" ) rank
196
197END PROGRAM interpol
198
199
200
201
202
Note: See TracBrowser for help on using the repository browser.