source: TOOLS/MOZAIC/src/MOZAIC/wri_wei.f90 @ 3326

Last change on this file since 3326 was 3326, checked in by omamce, 7 years ago

O.M. : Utility to generate interpolatio weights for OASIS-MCT
File size: 44.4 KB
Line 
1! -*- Mode: f90 -*-
2MODULE mod_wri_wei
3   !> Set of routine to write weights and adresses
4   USE modeles
5   USE formula
6   USE fliocom
7   USE errioipsl
8
9   LOGICAL :: l_nor2sou
10   
11   INTERFACE atm_reshape
12      MODULE PROCEDURE atm_reshape_2d_r, atm_reshape_3d_r, atm_reshape_2d_i
13   END INTERFACE atm_reshape
14
15CONTAINS
16   
17   FUNCTION atm_reshape_2d_r ( ptab )
18      IMPLICIT NONE
19      REAL (kind=rl), DIMENSION (jpai, jpaj) :: atm_reshape_2d_r
20      REAL (kind=rl), INTENT (in), DIMENSION (jpan) :: ptab
21      INTEGER :: jai, jaj, jan, jaj_rev
22     
23      DO jaj = 1, jpaj
24         IF (l_nor2sou) THEN
25            jaj_rev = jpaj - jaj + 1
26         ELSE
27            jaj_rev = jaj
28         END IF
29         DO jai = 1, jpai
30            jan = jai + jpai * ( jaj_rev - 1)
31            atm_reshape_2d_r (jai, jaj) = ptab (jan)
32         END DO
33      END DO
34   END FUNCTION atm_reshape_2d_r
35   
36   FUNCTION atm_reshape_3d_r ( ptab )
37      IMPLICIT NONE
38      REAL (kind=rl), DIMENSION (jpai, jpaj, jpae) :: atm_reshape_3d_r
39      REAL (kind=rl), INTENT (in), DIMENSION (jpan, jpae) :: ptab
40      INTEGER :: jai, jaj, jan, jaj_rev
41     
42      DO jaj = 1, jpaj
43         IF (l_nor2sou) THEN
44            jaj_rev = jpaj - jaj + 1
45         ELSE
46            jaj_rev = jaj
47         END IF
48         DO jai = 1, jpai
49            jan = jai + jpai * ( jaj_rev - 1)
50            atm_reshape_3d_r (jai, jaj, :) = ptab (jan, :)
51         END DO
52      END DO
53   END FUNCTION atm_reshape_3d_r
54   
55   FUNCTION atm_reshape_2d_i ( ktab )
56      IMPLICIT NONE
57      INTEGER, DIMENSION (jpai, jpaj) :: atm_reshape_2d_i
58      INTEGER, INTENT (in), DIMENSION (jpan) :: ktab
59      INTEGER :: jai, jaj, jan, jaj_rev
60     
61      DO jaj = 1, jpaj
62         IF (l_nor2sou) THEN
63            jaj_rev = jpaj - jaj + 1
64         ELSE
65            jaj_rev = jaj
66         END IF
67         DO jai = 1, jpai
68            jan = jai + jpai * ( jaj_rev - 1)
69            atm_reshape_2d_i (jai, jaj) = ktab (jan)
70         END DO
71      END DO
72   END FUNCTION atm_reshape_2d_i
73   
74   SUBROUTINE wri_weights_o2a (cldiag_o2a, clw_o2a, clw_o2a_mct, clnum, l_fulldiag, lo_src_grid_frac, lo_dst_grid_frac)
75      !> Write ocean -> atmosphere weights and adresses
76      IMPLICIT NONE
77      !!
78      CHARACTER (LEN=1), INTENT (in) :: clnum
79      CHARACTER (LEN=*), INTENT (in) :: cldiag_o2a, clw_o2a, clw_o2a_mct
80      LOGICAL, INTENT (in), OPTIONAL :: l_fulldiag, lo_src_grid_frac, lo_dst_grid_frac
81      INTEGER (KIND=il) :: nco2a, ierr, num_links, num_wgts 
82      INTEGER (KIND=il) :: il_ncid
83      INTEGER (KIND=il) :: jai, jaj, ja, jo, j_link
84      INTEGER (KIND=il) :: jn, jw, i_var, i_stat, isize_max, isize, ideb, ifin, ja_deb, ja_fin, ja_inc
85      LOGICAL :: l_fd, l_src_grid_frac, l_dst_grid_frac
86      CHARACTER (len=180) :: c_date, c_time, c_zone, c_tmp
87      !!
88      REAL    (kind=rl), DIMENSION (:,:,:), ALLOCATABLE :: w_3d
89      INTEGER (kind=il), DIMENSION (:,:,:), ALLOCATABLE :: k_3d
90      !!
91      REAL    (kind=rl), DIMENSION (:,:), ALLOCATABLE :: w_mct
92      INTEGER (kind=il), DIMENSION (:)  , ALLOCATABLE :: k_src, k_dst
93      !
94      l_fd = .TRUE.
95      IF (PRESENT (l_fulldiag)) THEN
96         l_fd = l_fulldiag
97      ELSE
98         !! Estimation de la taille des variables, limitation si > 2GB
99         i_var = jpoi * jpoj * jmo2a
100         IF ( i_var >= 2E9_il ) l_fd = .TRUE.
101      END IF
102     
103      IF ( PRESENT (lo_src_grid_frac) ) THEN
104         l_src_grid_frac = lo_src_grid_frac
105      ELSE
106          l_src_grid_frac = .TRUE.
107       END IF
108
109      IF ( PRESENT (lo_dst_grid_frac) ) THEN
110         l_dst_grid_frac = lo_dst_grid_frac
111      ELSE
112         l_dst_grid_frac = .TRUE.
113      END IF
114     
115      !!
116      !! Dataset ocean --> atmosphere
117      !!
118      clweight =  "WEIGHTS" // clnum ; cladress = "ADRESSE" // clnum
119      WRITE (unit = nout, fmt = *) " oce -> atm ", cladress, " ", clweight, " Neighbors : ", jmo2a
120      IF (c_oasis == '2.2' ) THEN
121         IF (l_wei_i4 .OR. l_wei_i8) WRITE (unit = nout, fmt = *) 'Ecriture o2a, fichiers binaires IEEE'
122         IF (l_wei_i4) THEN
123            WRITE (UNIT = nwei4o2a) cladress
124            WRITE (UNIT = nwei4o2a) INT  (ko2a (1_il:jmo2a, 1_il:jpan), KIND=i_4 )
125            WRITE (UNIT = nwei4o2a) clweight
126            WRITE (UNIT = nwei4o2a) REAL (wo2a (1_il:jmo2a, 1_il:jpan), KIND=rk_out )
127         ENDIF
128         IF (l_wei_i8) THEN
129            WRITE (UNIT = nwei8o2a) cladress
130            WRITE (UNIT = nwei8o2a) INT  (ko2a (1_il:jmo2a, 1_il:jpan), KIND=i_8 )
131            WRITE (UNIT = nwei8o2a) clweight
132            WRITE (UNIT = nwei8o2a) REAL (wo2a (1_il:jmo2a, 1_il:jpan), KIND=rk_out )
133         ENDIF
134      ENDIF
135      IF (l_wei_i4) THEN
136         WRITE (UNIT = nout, FMT = *) 'Ecriture OCEMASK i4r8 : non masque'
137         WRITE (UNIT = nwei4o2a) 'OCEMASK'//clnum
138         WRITE (UNIT = nout, FMT = *) 'Ecriture OCEMASK i4r8 : masque'
139         WRITE (UNIT = nwei4o2a) REAL (o2amask (1_il:jpan), KIND=rk_out )
140      END IF
141      IF (l_wei_i8) THEN
142         WRITE (UNIT = nout, FMT = *) 'Ecriture OCEMASK i8r8 : non masque'
143         WRITE (UNIT = nwei8o2a) 'OCEMASK'//clnum
144         WRITE (UNIT = nout, FMT = *) 'Ecriture i8r8 : masque'
145         WRITE (UNIT = nwei8o2a) REAL (o2amask (1_il:jpan), KIND=rk_out )
146         WRITE (UNIT = nout, FMT = *) 'Ecriture en binaire IEEE : fini '
147      ENDIF
148      !!
149      !! Output diagnostics in NetCDF file
150      !!
151      !CALL ipsldbg (new_status=.TRUE. )
152      WRITE (unit = nout, fmt = *) 'Ecriture o2a, diagnostiques ', TRIM(cldiag_o2a)
153      WRITE (unit = nout, fmt = *) 'Retournement nord/sud des champs : ', xalatt(1), xalatt(jpan), TRIM(o2a_orien)
154
155      IF (      TRIM(o2a_orien) .EQ. "nord_en_bas") THEN
156         WRITE (unit = nout, fmt = *) "Cas nord_en_bas"
157         IF ( xalatt(1) .GT. xalatt(jpan) ) THEN
158            l_nor2sou = .FALSE.
159            ja_deb =    1 ; ja_fin = jpaj ; ja_inc =  1
160         ELSE
161            l_nor2sou = .TRUE.
162            ja_deb = jpaj ; ja_fin =    1 ; ja_inc = -1
163         END IF
164      ELSE IF ( TRIM(o2a_orien) .EQ. "nord_en_haut") THEN
165         WRITE (unit = nout, fmt = *) "Cas nord_en_haut"
166         IF ( xalatt(1) .GT. xalatt(jpan) ) THEN
167            l_nor2sou = .TRUE.
168            ja_deb = jpaj ; ja_fin =    1 ; ja_inc = -1
169         ELSE
170            l_nor2sou = .FALSE.
171            ja_deb =    1 ; ja_fin = jpaj ; ja_inc =  1
172         END IF
173      ELSE
174         WRITE (unit = nout, fmt = *) "Cas inconnu"
175         l_nor2sou = .FALSE.
176         ja_deb =    1 ; ja_fin = jpaj ; ja_inc =  1
177      END IF
178
179      WRITE (unit = nout, fmt = *) 'Retournement nord/sud des champs : ', l_nor2sou, ja_deb, ja_fin, ja_inc
180
181      CALL fliocrfd (TRIM(cldiag_o2a) // TRIM(c_suffix), (/'x   ', 'y   ', 'n   ', 'edge'/), (/jpai, jpaj, jmo2a, jpae /),&
182         & nco2a, mode=c_FlioMode)
183      CALL fliopstc (nco2a, &
184         & x_axis_2d = atm_reshape(xalont), &
185         & y_axis_2d = atm_reshape(xalatt)  )
186      CALL flioputa (nco2a, '?', 'Comment', TRIM(c_comment) )
187      CALL fliodefv (nco2a, 'Weights_Max'//clnum, (/1_il,2_il/), v_t=flio_r4, standard_name='Oce -> Atm max weights')
188      CALL flioputa (nco2a, 'Weights_Max'//clnum, 'missing_value', 0.0_rl)
189      CALL fliodefv (nco2a, 'Neighbors'//clnum  , (/1_il,2_il/), v_t=flio_i4, standard_name='Oce -> Atm Neighbors')
190      CALL flioputa (nco2a, 'Neighbors'//clnum, 'missing_value', 0.0_rl)
191      CALL fliodefv (nco2a, 'Weights_Sum'//clnum, (/1_il,2_il/), v_t=flio_r4, standard_name='Oce -> Atm sum weights')
192      CALL flioputa (nco2a, 'Weights_Sum'//clnum, 'missing_value', 0.0_rl)
193      CALL fliodefv (nco2a, 'Mask', (/1_il,2_il/), v_t=flio_i4, standard_name='Oce -> Atm mask')
194      CALL flioputa (nco2a, 'Mask', 'missing_value', 0.0_rl)
195      CALL fliodefv (nco2a, 'OceMask', (/1_il,2_il/), v_t=flio_r4, standard_name='Oce ->Atm OceMask')
196      CALL flioputa (nco2a, 'OceMask', 'missing_value', 0.0_rl)
197      CALL fliodefv (nco2a, 'OceMask_int', (/1_il,2_il/), v_t=flio_i4, standard_name='Oce ->Atm OceMask')
198      CALL fliodefv (nco2a, 'OceMask_ext', (/1_il,2_il/), v_t=flio_i4, standard_name='Oce ->Atm OceMask')
199      CALL fliodefv (nco2a, 'LonEdge', (/1,2,4/), v_t=flio_r4)
200      CALL flioputa (nco2a, 'LonEdge', 'missing_value', 0.0_rl)
201      CALL fliodefv (nco2a, 'LatEdge', (/1,2,4/), v_t=flio_r4) 
202      CALL flioputa (nco2a, 'LatEdge', 'missing_value', 0.0_rl)
203      IF (l_fd) THEN
204         WRITE (nout,*) 'Fichier Diagnostics '
205         CALL fliodefv (nco2a, 'Weights'//clnum, (/1,2,3/), v_t=flio_r4, standard_name='Oce -> Atm Weights')
206         CALL flioputa (nco2a, 'Weights'//clnum, 'missing_value', 0.0_rl)
207         CALL fliodefv (nco2a, 'Adresses'//clnum,(/1,2,3/), v_t=flio_i4, standard_name='Oce -> Atm Adresses')
208         CALL flioputa (nco2a, 'Adresses'//clnum, 'missing_value', 0.0_rl)
209         CALL fliodefv (nco2a, 'Index_I'//clnum, (/1,2,3/), v_t=flio_i4 )
210         CALL flioputa (nco2a, 'Index_I'//clnum, 'missing_value', 0.0_rl)
211         CALL fliodefv (nco2a, 'Index_J'//clnum, (/1_il,2_il,3_il/), v_t=flio_i4 )
212         CALL flioputa (nco2a, 'Index_J'//clnum, 'missing_value', 0.0_rl)
213      ELSE
214          WRITE (nout,*) 'Pas de fichier diagnostics '
215      END IF
216      CALL fliodefv (nco2a, 'MaskPer', (/1_il,2_il/), v_t=flio_i4 )
217      CALL flioputa (nco2a, 'MaskPer', 'missing_value', 0.0_rl)
218      CALL fliodefv (nco2a, 'Surface', (/1,2/))
219      CALL flioputa (nco2a, 'Surface', 'missing_value', 0.0_rl)
220      CALL fliodefv (nco2a, 'SurfacePol', (/1,2/))
221      CALL flioputa (nco2a, 'SurfacePol', 'missing_value', 0.0_rl)
222      !!
223      CALL flioputv (nco2a, 'Weights_Max'//clnum, atm_reshape (MAXVAL(wo2a,DIM=1)) )
224      CALL flioputv (nco2a, 'Neighbors'//clnum,   atm_reshape (MAX(0_il, nva))     )
225      CALL flioputv (nco2a, 'Weights_Sum'//clnum, atm_reshape (SUM   (wo2a,DIM=1)) )
226      CALL flioputv (nco2a, 'Mask',               atm_reshape (1_il-iamskt)        )
227      CALL flioputv (nco2a, 'OceMask',            atm_reshape (o2amask)            )
228      CALL flioputv (nco2a, 'OceMask_int',        atm_reshape (o2amask_i_int)      )
229      CALL flioputv (nco2a, 'OceMask_ext',        atm_reshape (o2amask_i_ext)      )
230      CALL flioputv (nco2a, 'LonEdge',            atm_reshape (xa_ed)              )
231      CALL flioputv (nco2a, 'LatEdge',            atm_reshape (ya_ed)              )
232      CALL flioputv (nco2a, 'Surface',            atm_reshape (xasrft)             )
233      CALL flioputv (nco2a, 'SurfacePol',         atm_reshape (xasrft_pol)         )
234
235      IF (l_fd) THEN
236         ALLOCATE (w_3d(jpai, jpaj, jmo2a), STAT=ierr) 
237         CALL chk_allo (ierr, 'w_3d(jpai,jpaj,jmo2a)', lreset=.TRUE., crout='wri_wei_o2a')
238         ALLOCATE (k_3d(jpai, jpaj, jmo2a), STAT=ierr)
239         CALL chk_allo (ierr, 'k_3d(jpai,jpaj,jmo2a)')
240
241         DO jn = 1_il, jmo2a
242            DO jaj = 1_il, jpaj
243               DO jai = 1_il, jpai
244                  w_3d (jai, jaj, jn) = REAL(wo2a (jn, m1a(jai, jaj)), KIND=rl)
245                  k_3d (jai, jaj, jn) = INT (ko2a (jn, m1a(jai, jaj)), KIND=il)
246               END DO
247            END DO
248         END DO
249         IF (limit_stack) THEN
250            DO jn = 1_il, jmo2a
251               !WRITE (UNIT=nout,FMT='(1I4)') jn
252               CALL flioputv (nco2a, 'Weights'//clnum, w_3d(:,ja_deb:ja_fin:ja_inc,jn), start=(/1_il,1_il,jn/) )
253            END DO
254         ELSE
255            CALL flioputv (nco2a, 'Weights'//clnum, w_3d(:,ja_deb:ja_fin:ja_inc,:) )
256         ENDIF
257         !!
258         IF  (limit_stack) THEN
259            DO jn = 1_il, jmo2a
260               !WRITE (UNIT=nout,FMT='(1I4)') jn
261               CALL flioputv (nco2a, 'Adresses'//clnum, k_3d(:,ja_deb:ja_fin:ja_inc,jn), start=(/1_il,1_il,jn/) )
262            ENDDO
263         ELSE
264            CALL flioputv (nco2a, 'Adresses'//clnum, k_3d(:,ja_deb:ja_fin:ja_inc,:))
265         ENDIF
266         DEALLOCATE (w_3d)
267         !
268         k_3d = 0_il
269         DO jn = 1_il, jmo2a
270            DO jaj = 1_il, jpaj
271               DO jai = 1_il, jpai
272                  k_3d (jai, jaj, jn) = m2oi(ko2a(jn, m1a(jai, jaj)))
273               END DO
274            END DO
275         END DO
276         IF (limit_stack) THEN
277            DO jn = 1_il, jmo2a
278               !WRITE (UNIT=nout,FMT='(1I4)') jn
279               CALL flioputv (nco2a, 'Index_I'//clnum, k_3d(:,ja_deb:ja_fin:ja_inc,jn), start=(/1_il,1_il,jn/) )
280            ENDDO
281         ELSE
282            CALL flioputv (nco2a, 'Index_I'//clnum, k_3d(:,ja_deb:ja_fin:ja_inc,1:jmo2a)) 
283         ENDIF
284         k_3d = 0_il
285         DO jn = 1_il, jmo2a
286            DO jaj = 1_il, jpaj
287               DO jai = 1_il, jpai
288                  k_3d (jai, jaj, jn) = m2oj(ko2a(jn, m1a(jai, jaj)))
289               END DO
290            END DO
291         END DO
292         IF (limit_stack) THEN
293            DO jn = 1_il, jmo2a
294               !WRITE (UNIT=nout,FMT='(1I4)') jn
295               CALL flioputv (nco2a, 'Index_J'//clnum, k_3d(:,ja_deb:ja_fin:ja_inc,jn), start=(/1_il,1_il,jn/) )
296            ENDDO
297         ELSE
298            CALL flioputv (nco2a, 'Index_J'//clnum, k_3d(:,ja_deb:ja_fin:ja_inc,1:jmo2a)) 
299         ENDIF
300         DEALLOCATE (k_3d)
301      ENDIF
302      !!
303      WRITE (unit=nout,fmt=*) 'Fin ecriture diagnostiques o2a '
304      CALL flioclo (nco2a)
305      !!
306      IF ( l_wei_oasis_3 ) THEN
307         !! Ecriture des poids au format NetCDF de OASIS, format OASIS 3
308         !! O -> A
309         WRITE (unit=nout,fmt=*) 'Ecriture poids o2a NetCDF OASIS 3'
310         CALL fliocrfd (TRIM(clw_o2a) // TRIM(c_suffix) // '.nc' , (/'jmo2a', 'jpan '/), (/jmo2a, jpan/), il_ncid, mode=c_FlioMode )
311         CALL flioputa (il_ncid, '?', 'Comment', TRIM(c_comment) )
312         CALL fliodefv (il_ncid, 'WEIGHTS'//clnum, (/1, 2/), v_t=flio_r )
313         CALL fliodefv (il_ncid, 'ADRESSE'//clnum, (/1, 2/), v_t=flio_i )
314         ! Write WEIGHTS
315         IF (limit_stack) THEN
316            DO jn = 1, jmo2a
317               !WRITE (UNIT=nout,FMT='(1I4)') jn
318               CALL flioputv (il_ncid, 'WEIGHTS'//clnum, wo2a(jn,:), start=(/jn, 1/), count=(/1,jpan/) )
319            END DO
320         ELSE
321            CALL flioputv (il_ncid, 'WEIGHTS'//clnum, wo2a(1:jmo2a,:))
322         ENDIF
323         ! Write ADRESSE
324         IF (limit_stack) THEN
325            DO jn = 1, jmo2a
326               !WRITE (UNIT=nout,FMT='(1I4)') jn
327               CALL flioputv (il_ncid, 'ADRESSE'//clnum, ko2a(jn,:), start=(/jn, 1/), count=(/1,jpan/) )
328            END DO
329         ELSE
330            CALL flioputv (il_ncid, 'ADRESSE'//clnum, ko2a(1:jmo2a,:)) 
331         ENDIF
332         WRITE (unit=nout, fmt=*) 'Fin ecriture poids o2a NetCDF'
333         CALL flioclo (il_ncid)
334         !!
335         WRITE (unit=nout,fmt=*) 'Ecriture poids o2a NetCDF, format OASIS MCT'
336         num_links = jpan * jmo2a
337         num_wgts  = 1
338         ALLOCATE (w_mct(num_wgts,num_links), STAT=ierr) 
339         CALL chk_allo (ierr, 'w_mct(num_wgts,num_links)', lreset=.TRUE., crout='wri_wei_o2a')
340         ALLOCATE (k_src(num_links), STAT=ierr) 
341         CALL chk_allo (ierr, 'k_src(num_links)', lreset=.TRUE., crout='wri_wei_o2a')
342         ALLOCATE (k_dst(num_links), STAT=ierr) 
343         CALL chk_allo (ierr, 'k_dst(num_links)', lreset=.TRUE., crout='wri_wei_o2a')
344         !
345         j_link = 0
346         DO ja = 1, jpan
347            DO jn = 1, jmo2a
348               IF (  ko2a (jn, ja) /= 0 ) THEN
349                  j_link = j_link + 1
350                  k_dst (j_link)   = ja
351                  k_src (j_link)   = ko2a (jn, ja)
352                  w_mct (1,j_link) = wo2a (jn, ja) 
353               END IF
354            END DO
355         END DO
356         num_links = j_link
357
358      END IF
359     
360      IF ( l_wei_oasis_mct ) THEN
361         !! Ecriture des poids au format NetCDF de OASIS, format OASIS MCT
362         
363         CALL fliocrfd (TRIM(clw_o2a_mct) // TRIM(c_suffix), &
364            & (/'src_grid_size   ', 'dst_grid_size   ', 'src_grid_corners', 'dst_grid_corners'  , &
365            &   'src_grid_rank   ', 'dst_grid_rank   ', 'num_links       ', 'num_wgts        '/), &
366            & (/ jpon             , jpan              ,  4                ,  4                  , &
367            &    2                ,  2                ,  num_links        ,  num_wgts         /), &
368            & il_ncid, mode=c_FlioMode) 
369         CALL flioputa (il_ncid, "?", "title"         , TRIM(clw_o2a_mct) )
370         CALL flioputa (il_ncid, '?', 'Comment', TRIM(c_comment) )
371         CALL flioputa (il_ncid, "?", "normalization" , "none" )
372         CALL flioputa (il_ncid, "?", "map_method"    , "Conservative Remapping" )
373         CALL DATE_AND_TIME (c_date, c_time, c_zone )
374         CALL flioputa (il_ncid, "?", "history"       , "Created: "//c_date(1:4)//"-"//c_date(5:6)//"-"//c_date(7:8) &
375            & //" "//c_time(1:2)//"h"//c_time(3:4)//" GMT"//TRIM(c_zone) )
376         CALL flioputa (il_ncid, "?", "conventions"   , "SCRIP" )
377         CALL flioputa (il_ncid, "?", "method"        , "MOSAIC" )
378         CALL flioputa (il_ncid, "?", "source_grid"   , "curvilinear" )
379         CALL flioputa (il_ncid, "?", "dest_grid"     , "curvilinear" )
380         CALL flioputa (il_ncid, "?", "Institution"   , "IPSL" )
381         CALL flioputa (il_ncid, "?", "Model"         , "IPSL CM6" )
382         CALL flioputa (il_ncid, "?", "Max_nei_num"   , jmo2a )
383         CALL GET_ENVIRONMENT_VARIABLE ( NAME="HOSTNAME" , VALUE=c_tmp, TRIM_NAME=.TRUE., STATUS=i_stat)
384         IF ( i_stat == 0 ) THEN
385            CALL flioputa (il_ncid, "?", "HOSTNAME"     , TRIM(c_tmp) )
386         ELSE
387            WRITE (nout,*) 'Environment variable not found : $HOSTNAME'
388         END IF
389         CALL GET_ENVIRONMENT_VARIABLE ( NAME="LOGNAME" , VALUE=c_tmp, TRIM_NAME=.TRUE., STATUS=i_stat)
390         IF ( i_stat == 0 ) THEN
391            CALL flioputa (il_ncid, "?", "LOGNAME"      , TRIM(c_tmp) )
392         ELSE
393            WRITE (nout,*) 'Environment variable not found : $LOGNAME'
394         END IF
395         !
396         CALL fliodefv (il_ncid, 'src_grid_dims'      , (/5/)  , v_t=flio_i )
397         CALL fliodefv (il_ncid, 'dst_grid_dims'      , (/6/)  , v_t=flio_i )
398         CALL fliodefv (il_ncid, 'src_grid_center_lat', (/1/)  , v_t=flio_r , units = "degrees_north" )
399         CALL fliodefv (il_ncid, 'src_grid_center_lon', (/1/)  , v_t=flio_r , units = "degrees_east" )
400         CALL fliodefv (il_ncid, 'dst_grid_center_lat', (/2/)  , v_t=flio_r , units = "degrees_north" )
401         CALL fliodefv (il_ncid, 'dst_grid_center_lon', (/2/)  , v_t=flio_r , units = "degrees_east" )
402         CALL fliodefv (il_ncid, 'src_grid_corner_lat', (/3,1/), v_t=flio_r , units = "degrees_north" )
403         CALL fliodefv (il_ncid, 'src_grid_corner_lon', (/3,1/), v_t=flio_r , units = "degrees_east" )
404         CALL fliodefv (il_ncid, 'dst_grid_corner_lat', (/4,2/), v_t=flio_r , units = "degrees_north" )
405         CALL fliodefv (il_ncid, 'dst_grid_corner_lon', (/4,2/), v_t=flio_r , units = "degrees_east" )
406         CALL fliodefv (il_ncid, 'src_grid_imask'     , (/1/)  , v_t=flio_i , units = "unitless"      )
407         CALL fliodefv (il_ncid, 'dst_grid_imask'     , (/2/)  , v_t=flio_i , units = "unitless"      )
408         CALL fliodefv (il_ncid, 'src_grid_area'      , (/1/)  , v_t=flio_r , units = "m^2" )
409         CALL fliodefv (il_ncid, 'dst_grid_area'      , (/2/)  , v_t=flio_r , units = "m^2" )
410         CALL fliodefv (il_ncid, 'src_grid_frac'      , (/1/)  , v_t=flio_r , units = "unitless"      )
411         CALL fliodefv (il_ncid, 'dst_grid_frac'      , (/2/)  , v_t=flio_r , units = "unitless"      )
412         CALL fliodefv (il_ncid, 'dst_address'        , (/7/)  , v_t=flio_i )
413         CALL fliodefv (il_ncid, 'src_address'        , (/7/)  , v_t=flio_i )
414         CALL fliodefv (il_ncid, 'remap_matrix'       , (/8,7/), v_t=flio_r )
415         !   
416         CALL flioputa (il_ncid, 'src_grid_imask', 'land_value', 0)
417         CALL flioputa (il_ncid, 'src_grid_imask', 'sea_value' , 1)
418         CALL flioputa (il_ncid, 'dst_grid_imask', 'land_value', 0)
419         CALL flioputa (il_ncid, 'dst_grid_imask', 'sea_value' , 1)
420         !
421         CALL flioputv (il_ncid, 'src_grid_dims'      , (/ jpoi, jpoj /) ) 
422         CALL flioputv (il_ncid, 'dst_grid_dims'      , (/ jpai, jpaj /) )
423         CALL flioputv (il_ncid, 'src_grid_center_lat',         xolatt )
424         CALL flioputv (il_ncid, 'src_grid_center_lon', lon_180(xolont))
425         CALL flioputv (il_ncid, 'dst_grid_center_lat',         xalatt )
426         CALL flioputv (il_ncid, 'dst_grid_center_lon', lon_180(xalont))
427         
428         CALL flioputv (il_ncid, 'src_grid_corner_lat',         yo_ed (:,1)  , start=(/1,1/), count=(/1,jpon/) )
429         CALL flioputv (il_ncid, 'src_grid_corner_lat',         yo_ed (:,3)  , start=(/2,1/), count=(/1,jpon/) )
430         CALL flioputv (il_ncid, 'src_grid_corner_lat',         yo_ed (:,5)  , start=(/3,1/), count=(/1,jpon/) )
431         CALL flioputv (il_ncid, 'src_grid_corner_lat',         yo_ed (:,8)  , start=(/4,1/), count=(/1,jpon/) )
432         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xo_ed (:, 1)), start=(/1,1/), count=(/1,jpon/) )
433         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xo_ed (:, 3)), start=(/2,1/), count=(/1,jpon/) )
434         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xo_ed (:, 5)), start=(/3,1/), count=(/1,jpon/) )
435         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xo_ed (:, 8)), start=(/4,1/), count=(/1,jpon/) )
436         
437         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         ya_ed (:, 1) , start=(/1,1/), count=(/1,jpan/) )
438         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         ya_ed (:, 3) , start=(/2,1/), count=(/1,jpan/) )
439         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         ya_ed (:, 5) , start=(/3,1/), count=(/1,jpan/) )
440         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         ya_ed (:, 8) , start=(/4,1/), count=(/1,jpan/) )
441         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xa_ed (:, 1)), start=(/1,1/), count=(/1,jpan/) )
442         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xa_ed (:, 3)), start=(/2,1/), count=(/1,jpan/) )
443         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xa_ed (:, 5)), start=(/3,1/), count=(/1,jpan/) )
444         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xa_ed (:, 8)), start=(/4,1/), count=(/1,jpan/) )
445         
446         CALL flioputv (il_ncid, 'src_grid_imask'     , (1-iomskt)*(1-iomskp) )
447         CALL flioputv (il_ncid, 'dst_grid_imask'     , 1-o2amask_i_int*(1-iomskp) )
448         CALL flioputv (il_ncid, 'src_grid_area'      , xosrft )
449         CALL flioputv (il_ncid, 'dst_grid_area'      , xasrft )
450         
451         CALL flioputv (il_ncid, 'dst_grid_frac'      , o2amask )
452         
453         
454         IF (l_src_grid_frac) THEN
455            CALL flioputv (il_ncid, 'src_grid_frac'      , REAL ((1-iomskt)*(1-iomskp),KIND=rl) )
456         ELSE
457            CALL flioputv (il_ncid, 'src_grid_frac'      , REAL (1-0*iomskt,KIND=rl) )
458         ENDIF
459         IF (l_dst_grid_frac) THEN
460            CALL flioputv (il_ncid, 'dst_grid_frac'      , o2amask )
461         ELSE
462            CALL flioputv (il_ncid, 'dst_grid_frac'      , 1.0_rl+0.0_rl*o2amask )
463         END IF
464         
465         CALL flioputv (il_ncid, 'dst_address'        , k_dst (1:num_links) )
466         CALL flioputv (il_ncid, 'src_address'        , k_src (1:num_links) )
467         CALL flioputv (il_ncid, 'remap_matrix '      , w_mct (1:num_wgts,1:num_links) )
468         
469         !!
470         CALL flioclo (il_ncid)
471      END IF
472     
473      RETURN
474     
475   END SUBROUTINE wri_weights_o2a
476   !!
477   SUBROUTINE wri_weights_a2o (cldiag_a2o, clw_a2o, clw_a2o_mct, clnum, l_fulldiag, lo_src_grid_frac, lo_dst_grid_frac, &
478                               co_omsk, co_amsk )
479      !> Write atmosphere -> ocean weights and adresses
480      IMPLICIT NONE
481      !!
482      CHARACTER (len=1), INTENT (in) :: clnum
483      CHARACTER (len=*) :: cldiag_a2o, clw_a2o, clw_a2o_mct
484      LOGICAL, INTENT (in), OPTIONAL :: l_fulldiag, lo_src_grid_frac, lo_dst_grid_frac
485      CHARACTER (len=*), INTENT (in), OPTIONAL :: co_omsk, co_amsk
486      INTEGER (KIND=il) :: nca2o, ierr, num_links, num_wgts 
487      INTEGER (KIND=il) :: il_ncid
488      INTEGER (KIND=il) :: joi, joj, ja, jo, j_link
489      INTEGER (KIND=il) :: jn, jw, j1, j2, i_var, i_stat, isize_max, isize, ideb, ifin
490      LOGICAL :: l_fd, l_src_grid_frac, l_dst_grid_frac
491      CHARACTER (len=20) :: c_omsk, c_amsk
492      CHARACTER (len=180) :: c_date, c_time, c_zone, c_tmp
493      !!
494      REAL    (KIND=rl), DIMENSION (:,:,:), ALLOCATABLE :: w_3d
495      INTEGER (KIND=il), DIMENSION (:,:,:), ALLOCATABLE :: k_3d
496      !!
497      REAL    (kind=rl), DIMENSION (:,:), ALLOCATABLE :: w_mct
498      INTEGER (kind=il), DIMENSION (:)  , ALLOCATABLE :: k_src, k_dst
499      !
500      l_fd = .TRUE.
501      IF (PRESENT (l_fulldiag)) THEN
502         l_fd = l_fulldiag
503      ELSE
504         !! Estimation de la taille des variables, limitation si > 2GB
505         i_var = jpoi * jpoj * jmo2a
506         IF ( i_var >= 2E9_il ) l_fd = .TRUE.
507      END IF
508
509      IF ( PRESENT (lo_src_grid_frac) ) THEN
510         l_src_grid_frac = lo_src_grid_frac
511      ELSE
512         l_src_grid_frac = .TRUE.
513      END IF
514      WRITE (nout,*) 'wri_wei_a2o : l_src_grid_frac  : ', l_src_grid_frac 
515
516      IF ( PRESENT (lo_dst_grid_frac) ) THEN
517         l_dst_grid_frac = lo_dst_grid_frac
518      ELSE
519         l_dst_grid_frac = .TRUE.
520      END IF
521      WRITE (nout,*) 'wri_wei_a2o : l_dst_grid_frac : ', l_dst_grid_frac
522
523      IF ( PRESENT (co_omsk) ) THEN
524         c_omsk = TRIM(co_omsk)
525      ELSE
526         c_omsk = 'perio'
527      END IF
528      WRITE (nout,*) 'wri_wei_a2o : c_omsk : ', TRIM ( c_omsk)
529
530      IF ( PRESENT (co_amsk) ) THEN
531         c_amsk = TRIM( co_amsk) 
532      ELSE
533         c_amsk = 'int'
534      END IF
535      WRITE (nout,*) 'wri_wei_a2o : c_amsk : ', TRIM(c_amsk)
536
537      !IF ( LEN_TRIM(c_suffix) /= 0) c_suffix = '_' // TRIM(c_suffix)
538      !!     
539      !! Dataset atmosphere --> ocean
540      !!
541      clweight =  "WEIGHTS" // clnum ; cladress = "ADRESSE" // clnum
542      WRITE (UNIT = nout, fmt = *) " atm -> oce ", cladress, " ", clweight, " Number of neighbors : ", jma2o
543      IF (c_oasis == '2.2' ) THEN
544         IF (l_wei_i4 .OR. l_wei_i8) WRITE (unit = nout, fmt = *) 'Ecriture a2o, fichiers binaires IEEE'
545         IF (l_wei_i4) THEN
546            WRITE (UNIT = nwei4a2o) cladress
547            WRITE (UNIT = nwei4a2o) ((INT (ka2o (jn, jo) , KIND=i_4), jn = 1_il, jma2o), jo = 1_il, jpon)
548            WRITE (UNIT = nwei4a2o) clweight
549            WRITE (UNIT = nwei4a2o) ((REAL (wa2o (jn, jo), KIND=rk_out), jn = 1_il, jma2o), jo = 1_il, jpon)
550         END IF
551         IF (l_wei_i8) THEN
552            WRITE (UNIT = nwei8a2o) cladress
553            WRITE (UNIT = nwei8a2o) ((INT  (ka2o (jn, jo), KIND=i_8), jn = 1_il, jma2o), jo = 1_il, jpon)
554            WRITE (UNIT = nwei8a2o) clweight
555            WRITE (UNIT = nwei8a2o) ((REAL (wa2o (jn, jo), KIND=rk_out), jn = 1_il, jma2o), jo = 1_il, jpon)
556         END IF
557      ENDIF
558
559      ! CALL ipsldbg (new_status=.TRUE. )
560      WRITE (unit = nout, fmt = *) 'Ecriture a2o, diagnostiques ', TRIM(cldiag_a2o)
561      CALL fliocrfd (TRIM(cldiag_a2o) // TRIM(c_suffix), (/'x   ', 'y   ', 'n   ', 'edge'/), (/jpoi, jpoj, jma2o, jpoe/), &
562         &nca2o, mode=c_FlioMode)
563      CALL fliopstc (nca2o, & 
564         & x_axis_2d = RESHAPE (xolont, (/jpoi, jpoj/)), &
565         & y_axis_2d = RESHAPE (xolatt, (/jpoi, jpoj/)))
566      CALL flioputa (nca2o, '?', 'Comment', TRIM(c_comment) )
567      CALL fliodefv (nca2o, 'Weights_Max'//clnum, (/1_il,2_il/), v_t=flio_r4, standard_name='Oce -> Atm max weights')
568      CALL flioputa (nca2o, 'Weights_Max'//clnum, 'missing_value', 0.0_rl)
569      CALL fliodefv (nca2o, 'Neighbors'//clnum  , (/1_il,2_il/), v_t=flio_i4, standard_name='Oce -> Atm Neighbors')
570      CALL flioputa (nca2o, 'Neighbors'//clnum, 'missing_value', 0.0_rl)
571      CALL fliodefv (nca2o, 'Weights_Sum'//clnum, (/1_il,2_il/), v_t=flio_r4, standard_name='Oce -> Atm sum weights')
572      CALL flioputa (nca2o, 'Weights_Sum'//clnum, 'missing_value', 0.0_rl)
573      CALL fliodefv (nca2o, 'Mask', (/1_il,2_il/), v_t=flio_i4, standard_name='Oce -> Atm mask')
574      CALL flioputa (nca2o, 'Mask', 'missing_value', 0.0_rl)
575      CALL fliodefv (nca2o, 'AtmMask', (/1_il,2_il/), v_t=flio_r4, standard_name='Oce ->Atm OceMask')
576      CALL flioputa (nca2o, 'AtmMask', 'missing_value', 0.0_rl)
577      CALL fliodefv (nca2o, 'LonEdge', (/1_il,2_il,4_il/), v_t=flio_r4)
578      CALL flioputa (nca2o, 'LonEdge', 'missing_value', 0.0_rl)
579      CALL fliodefv (nca2o, 'LatEdge', (/1_il,2_il,4_il/), v_t=flio_r4) 
580      CALL flioputa (nca2o, 'LatEdge', 'missing_value', 0.0_rl)
581      IF (l_fd) THEN
582         CALL fliodefv (nca2o, 'Weights'//clnum, (/1_il,2_il,3_il/), v_t=flio_r4, standard_name='Oce -> Atm Weights')
583         CALL flioputa (nca2o, 'Weights'//clnum, 'missing_value', 0.0_rl)
584         CALL fliodefv (nca2o, 'Adresses'//clnum,(/1_il,2_il,3_il/), v_t=flio_i4, standard_name='Oce -> Atm Adresses')
585         CALL flioputa (nca2o, 'Adresses'//clnum, 'missing_value', 0.0_rl)
586         CALL fliodefv (nca2o, 'Index_I'//clnum, (/1_il,2_il,3_il/), v_t=flio_i4)
587         CALL flioputa (nca2o, 'Index_I'//clnum, 'missing_value', 0.0_rl)
588         CALL fliodefv (nca2o, 'Index_J'//clnum, (/1_il,2_il,3_il/), v_t=flio_i4)
589         CALL flioputa (nca2o, 'Index_J'//clnum, 'missing_value', 0.0_rl)
590      END IF
591      CALL fliodefv (nca2o, 'MaskPer', (/1_il,2_il/), v_t=flio_i4)
592      CALL flioputa (nca2o, 'MaskPer', 'missing_value', 0.0_rl)
593      CALL fliodefv (nca2o, 'Surface', (/1_il,2_il/))
594      CALL flioputa (nca2o, 'Surface', 'missing_value', 0.0_rl)
595      CALL fliodefv (nca2o, 'SurfacePol', (/1_il,2_il/))
596      CALL flioputa (nca2o, 'SurfacePol', 'missing_value', 0.0_rl)
597
598      ALLOCATE (w_3d(jpoi, jpoj, 1), STAT=ierr) ; CALL chk_allo (ierr, 'w_3d(jpoi,jpoj,1)')
599      w_3d (1:jpoi , 1:jpoj, 1) = RESHAPE (MAXVAL (wa2o,DIM=1), (/jpoi, jpoj/))
600      CALL flioputv (nca2o, 'Weights_Max'//clnum, w_3d (1:jpoi, 1:jpoj, 1) )
601      !CALL flioputv (nca2o, 'Weights_Max'//clnum, RESHAPE(MAXVAL(wa2o,DIM=1),(/jpoi, jpoj/)) )
602      CALL flioputv (nca2o, 'Neighbors'//clnum,   RESHAPE ( MAX (0_il, nvo) ,(/jpoi, jpoj/)) )
603      CALL flioputv (nca2o, 'Weights_Sum'//clnum, RESHAPE ( SUM (wa2o,DIM=1),(/jpoi, jpoj/)) )
604      CALL flioputv (nca2o, 'Mask',    RESHAPE (1_il-iomskt, (/jpoi, jpoj/)) )
605      CALL flioputv (nca2o, 'AtmMask', RESHAPE (a2omask, (/jpoi, jpoj/)) )
606      CALL flioputv (nca2o, 'LonEdge', RESHAPE (xo_ed, (/jpoi, jpoj, jpoe/)) )
607      CALL flioputv (nca2o, 'LatEdge', RESHAPE (yo_ed, (/jpoi, jpoj, jpoe/)) )
608      CALL flioputv (nca2o, 'Surface', RESHAPE (xosrft, (/jpoi,jpoj/)))
609      CALL flioputv (nca2o, 'SurfacePol', RESHAPE(xosrft_pol, (/jpoi,jpoj/)))
610      DEALLOCATE (w_3d)
611     
612      IF (l_fd) THEN
613         ALLOCATE (w_3d(jpoi, jpoj, jma2o), STAT=ierr)
614         CALL chk_allo (ierr, 'w_3d(jpoi,jpoj,jma2o)', lreset=.TRUE., crout='wri_wei_a2o')
615         ALLOCATE (k_3d(jpoi, jpoj, jma2o), STAT=ierr)
616         CALL chk_allo (ierr, 'k_3d(jpai,jpaj,jmo2a)')
617         
618         IF (ierr /= 0 ) THEN
619            WRITE(UNIT=nout,fmt=*) 'Erreur allocation k_3d dans wri_wei_a2o : ', ierr
620            STOP
621         END IF
622         DO jn = 1_il, jma2o
623            DO joj = 1_il, jpoj
624               DO joi = 1_il, jpoi
625                  w_3d (joi, joj, jn) = wa2o (jn, m1o(joi, joj))
626                  k_3d (joi, joj, jn) = ka2o (jn, m1o(joi, joj))
627               END DO
628            END DO
629         END DO
630         !!
631         IF (limit_stack) THEN
632            DO jn = 1_il, jma2o
633               !WRITE (UNIT=nout,FMT='(1I4)') jn
634               CALL flioputv (nca2o, 'Weights'//clnum, w_3d(:,:,jn), start=(/1_il, 1_il, jn/) )
635            ENDDO
636         ELSE
637            CALL flioputv (nca2o, 'Weights'//clnum, w_3d(:,:,:) )
638         ENDIF
639         !!
640         IF (limit_stack) THEN
641            DO jn = 1_il, jma2o
642               !WRITE (UNIT=nout,FMT='(1I4)') jn
643               CALL flioputv (nca2o, 'Adresses'//clnum, k_3d(:,:,jn), start=(/1_il, 1_il, jn/) )
644            ENDDO
645         ELSE
646            CALL flioputv (nca2o, 'Adresses'//clnum, k_3d(:,:,1:jma2o)) 
647         ENDIF
648         !!
649         CALL flioputv (nca2o, 'MaskPer',  & 
650            RESHAPE( (1_il-iomskt)*(1_il-iomskp), (/jpoi, jpoj/) ) )
651         !!
652         DEALLOCATE (w_3d)
653         !!
654         k_3d = 0_il
655         DO jn = 1_il, jma2o
656            DO joj = 1_il, jpoj
657               DO joi = 1_il, jpoi
658                  k_3d (joi, joj, jn) = m2ai(ka2o(jn, m1o(joi, joj)))
659               END DO
660            END DO
661         END DO
662         IF (limit_stack) THEN
663            DO jn = 1_il, jma2o
664               !WRITE (UNIT=nout,FMT='(1I4)') jn
665               CALL flioputv (nca2o, 'Index_I'//clnum, k_3d(:,:,jn), start=(/1_il,1_il,jn/) )
666            ENDDO
667         ELSE
668            CALL flioputv (nca2o, 'Index_I'//clnum, k_3d(:,:,1:jma2o)) 
669         ENDIF
670         k_3d = 0_il
671         DO jn = 1_il, jma2o
672            DO joj = 1_il, jpoj
673               DO joi = 1_il, jpoi
674                  k_3d (joi, joj, jn) = m2aj(ka2o (jn, m1o(joi, joj)))
675               END DO
676            END DO
677         END DO
678         IF (limit_stack) THEN
679            DO jn = 1_il, jma2o
680               !WRITE (UNIT=nout,FMT='(1I4)') jn
681               CALL flioputv (nca2o, 'Index_J'//clnum, k_3d(:,:,jn), start=(/1_il,1_il,jn/) )
682            END DO
683         ELSE
684            CALL flioputv (nca2o, 'Index_J'//clnum, k_3d(:,:,1:jma2o))
685         ENDIF
686         !
687         DEALLOCATE (k_3d)
688         !!
689      END IF
690      !!
691      WRITE (unit=nout,fmt=*) 'Fin ecriture diagnostiques a2o '
692      CALL flioclo (nca2o)
693      !!
694      !!
695      !! Ecriture des poids au format NetCDF de OASIS 3
696      IF ( l_wei_oasis_3 ) THEN
697         WRITE (unit=nout,fmt=*) 'Ecriture poids a2o NetCDF, format OASIS 3'
698         CALL fliocrfd (TRIM(clw_a2o) // TRIM(c_suffix) // '.nc', (/'jma2o', 'jpon '/), (/jma2o, jpon/), il_ncid, mode=c_FlioMode)
699         CALL flioputa (il_ncid, '?', 'Comment', TRIM(c_comment) )
700         CALL fliodefv (il_ncid, 'WEIGHTS'//clnum, (/1,2/), v_t=flio_r)
701         CALL fliodefv (il_ncid, 'ADRESSE'//clnum, (/1,2/), v_t=flio_i)
702         ! Write WEIGHTS
703         IF (limit_stack) THEN
704            j1 = 1 ; j2 = MIN (slice_size, jma2o)
705            DO WHILE (j1 < jma2o)
706               WRITE (UNIT=nout,FMT='("Ecriture wa2o, jn : ", 2I6, 5I8)') j1, j2, SIZE (wa2o(j1:j2,:))
707               CALL flioputv (il_ncid, 'WEIGHTS'//clnum, wa2o(j1:j2,:), start=(/j1,1_il/), count=(/j2-j1+1,jpon/) )
708               j1 = j1 + slice_size ; j2 = MIN (j1+slice_size-1, jma2o)
709            END DO
710         ELSE
711            WRITE (UNIT=nout,FMT='(5I10)') SIZE (wa2o(1:jma2o,:)), SIZE(wa2o(1:jma2o,:),DIM=1), SIZE(wa2o(1:jma2o,:),DIM=2) 
712            CALL flioputv (il_ncid, 'WEIGHTS'//clnum, wa2o(1:jma2o,:) )
713         ENDIF
714         ! Write ADRESSE
715         IF (limit_stack) THEN
716            j1 = 1 ; j2 = MIN (slice_size, jma2o)
717            DO WHILE ( j1 < jma2o)
718               WRITE (UNIT=nout,FMT='("Ecriture ka2o, jn : ", 2I6, 5I8)') j1, j2, SIZE (ka2o(j1:j2,:))
719               CALL flioputv (il_ncid, 'ADRESSE'//clnum, ka2o(j1:j2,:), start=(/j1,1_il/), count=(/j2-j1+1,jpon/) )
720               j1 = j1 + slice_size ; j2 = MIN (j1+slice_size-1, jma2o)
721            END DO
722         ELSE
723            WRITE (UNIT=nout,FMT='(5I10)') SIZE (ka2o(1:jma2o,:)), SIZE (ka2o(1:jma2o,:),DIM=1), SIZE (ka2o(1:jma2o,:),DIM=2) 
724            CALL flioputv (il_ncid, 'ADRESSE'//clnum, ka2o(1:jma2o,:) ) 
725         ENDIF
726         !!
727         WRITE (unit=nout, fmt=*) 'Fin ecriture adresses a2o NetCDF, format OASIS 3'
728         CALL flioclo (il_ncid)
729         !!
730         WRITE (unit=nout,fmt=*) 'Ecriture poids a2o NetCDF, format OASIS MCT'
731         num_links = jpon * jma2o
732         num_wgts  = 1
733         ALLOCATE (w_mct(num_wgts,num_links), STAT=ierr) 
734         CALL chk_allo (ierr, 'w_mct(num_wgts,num_links)', lreset=.TRUE., crout='wri_wei_a2o')
735         ALLOCATE (k_src(num_links), STAT=ierr) 
736         CALL chk_allo (ierr, 'k_src(num_links)', lreset=.TRUE., crout='wri_wei_a2o')
737         ALLOCATE (k_dst(num_links), STAT=ierr) 
738         CALL chk_allo (ierr, 'k_dst(num_links)', lreset=.TRUE., crout='wri_wei_a2o')
739         !
740         j_link = 0
741         DO jo = 1, jpon
742            DO jn = 1, jma2o
743               IF ( ka2o (jn, jo) /= 0 ) THEN
744                  j_link = j_link + 1
745                  k_dst (j_link)   = jo
746                  k_src (j_link)   = ka2o (jn, jo)
747                  w_mct (1,j_link) = wa2o (jn, jo) 
748               END IF
749            END DO
750         END DO
751         num_links = j_link
752         !
753      END IF
754      !
755         !! Ecriture des poids au format NetCDF de OASIS MCT
756      IF ( l_wei_oasis_mct ) THEN
757         CALL fliocrfd (TRIM(clw_a2o_mct) // TRIM(c_suffix), &
758            & (/'src_grid_size   ', 'dst_grid_size   ', 'src_grid_corners', 'dst_grid_corners',   &
759            &   'src_grid_rank   ', 'dst_grid_rank   ', 'num_links       ', 'num_wgts        '/), &
760            & (/ jpan             ,  jpon             ,  4                ,  4                ,   &
761            &    2                ,  2                ,  num_links        ,  num_wgts         /), &
762            & il_ncid, mode=c_FlioMode) 
763         CALL flioputa (il_ncid, "?", "title"         , TRIM(clw_a2o_mct) )
764         CALL flioputa (il_ncid, '?', 'Comment', TRIM(c_comment) )
765         CALL flioputa (il_ncid, "?", "normalization" , "none" )
766         CALL flioputa (il_ncid, "?", "map_method"    , "Conservative Remapping" )
767         CALL DATE_AND_TIME (c_date, c_time, c_zone )
768         CALL flioputa (il_ncid, "?", "history"       , "Created: "//c_date(1:4)//"-"//c_date(5:6)//"-"// &
769            & c_date(7:8)//" "//c_time(1:2)//"h"//c_time(3:4)//" GMT"//TRIM(c_zone) )
770         CALL flioputa (il_ncid, "?", "conventions"   , "SCRIP" )
771         CALL flioputa (il_ncid, "?", "method"        , "MOSAIC" )
772         CALL flioputa (il_ncid, "?", "source_grid"   , "curvilinear" )
773         CALL flioputa (il_ncid, "?", "dest_grid"     , "curvilinear" )
774         CALL flioputa (il_ncid, "?", "Institution"   , "IPSL" )
775         CALL flioputa (il_ncid, "?", "Model"         , "IPSL CM6" )
776         CALL flioputa (il_ncid, "?", "Max_nei_num"   , jma2o )
777         CALL flioputa (il_ncid, "?", "c_amsk"        , TRIM(c_amsk))
778         CALL flioputa (il_ncid, "?", "c_omsk"        , TRIM(c_omsk))
779         CALL GET_ENVIRONMENT_VARIABLE ( NAME="HOSTNAME", VALUE=c_tmp, TRIM_NAME=.TRUE., STATUS=i_stat)
780         IF ( i_stat == 0 ) THEN
781            CALL flioputa (il_ncid, "?", "HOSTNAME"     , TRIM(c_tmp) )
782         ELSE
783            WRITE (nout,*) 'Environment variable not found : $HOSTNAME'
784         END IF
785         CALL GET_ENVIRONMENT_VARIABLE ( NAME="LOGNAME" , VALUE=c_tmp, TRIM_NAME=.TRUE., STATUS=i_stat)
786         IF ( i_stat == 0 ) THEN
787            CALL flioputa (il_ncid, "?", "LOGNAME"      , TRIM(c_tmp) )
788         ELSE
789            WRITE (nout,*) 'Environment variable not found : $LOGNAME'
790         END IF
791         !
792         CALL fliodefv (il_ncid, 'src_grid_dims'      , (/5/)  , v_t=flio_i )
793         CALL fliodefv (il_ncid, 'dst_grid_dims'      , (/6/)  , v_t=flio_i )
794         CALL fliodefv (il_ncid, 'src_grid_center_lat', (/1/)  , v_t=flio_r , units = "degrees_north" )
795         CALL fliodefv (il_ncid, 'src_grid_center_lon', (/1/)  , v_t=flio_r , units = "degrees_east"  )
796         CALL fliodefv (il_ncid, 'dst_grid_center_lat', (/2/)  , v_t=flio_r , units = "degrees_north" )
797         CALL fliodefv (il_ncid, 'dst_grid_center_lon', (/2/)  , v_t=flio_r , units = "degrees_east"  )
798         CALL fliodefv (il_ncid, 'src_grid_corner_lat', (/3,1/), v_t=flio_r , units = "degrees_north" )
799         CALL fliodefv (il_ncid, 'src_grid_corner_lon', (/3,1/), v_t=flio_r , units = "degrees_east"  )
800         CALL fliodefv (il_ncid, 'dst_grid_corner_lat', (/4,2/), v_t=flio_r , units = "degrees_north" )
801         CALL fliodefv (il_ncid, 'dst_grid_corner_lon', (/4,2/), v_t=flio_r , units = "degrees_east"  )
802         CALL fliodefv (il_ncid, 'src_grid_imask'     , (/1/)  , v_t=flio_i , units = "unitless"      )
803         CALL fliodefv (il_ncid, 'dst_grid_imask'     , (/2/)  , v_t=flio_i , units = "unitless"      )
804         CALL fliodefv (il_ncid, 'src_grid_area'      , (/1/)  , v_t=flio_r , units = "m^2" )
805         CALL fliodefv (il_ncid, 'dst_grid_area'      , (/2/)  , v_t=flio_r , units = "m^2" )
806         CALL fliodefv (il_ncid, 'src_grid_frac'      , (/1/)  , v_t=flio_r , units = "unitless"      )
807         CALL fliodefv (il_ncid, 'dst_grid_frac'      , (/2/)  , v_t=flio_r , units = "unitless"      )
808         CALL fliodefv (il_ncid, 'dst_address'        , (/7/)  , v_t=flio_i )
809         CALL fliodefv (il_ncid, 'src_address'        , (/7/)  , v_t=flio_i )
810         CALL fliodefv (il_ncid, 'remap_matrix'       , (/8,7/), v_t=flio_r )
811         !
812         CALL flioputa (il_ncid, 'src_grid_imask', 'land_value', 0)
813         CALL flioputa (il_ncid, 'src_grid_imask', 'sea_value' , 1)
814         CALL flioputa (il_ncid, 'dst_grid_imask', 'land_value', 0)
815         CALL flioputa (il_ncid, 'dst_grid_imask', 'sea_value' , 1)
816         !
817         CALL flioputv (il_ncid, 'src_grid_dims'      , (/ jpai, jpaj /) ) 
818         CALL flioputv (il_ncid, 'dst_grid_dims'      , (/ jpoi, jpoj /) )
819         CALL flioputv (il_ncid, 'src_grid_center_lat',         xalatt )
820         CALL flioputv (il_ncid, 'src_grid_center_lon', lon_180(xalont))
821         CALL flioputv (il_ncid, 'dst_grid_center_lat',         xolatt )
822         CALL flioputv (il_ncid, 'dst_grid_center_lon', lon_180(xolont))
823         
824         CALL flioputv (il_ncid, 'src_grid_corner_lat',         ya_ed (:,1) , start=(/1,1/), count=(/1,jpan/) )
825         CALL flioputv (il_ncid, 'src_grid_corner_lat',         ya_ed (:,3) , start=(/2,1/), count=(/1,jpan/) )
826         CALL flioputv (il_ncid, 'src_grid_corner_lat',         ya_ed (:,5) , start=(/3,1/), count=(/1,jpan/) )
827         CALL flioputv (il_ncid, 'src_grid_corner_lat',         ya_ed (:,8) , start=(/4,1/), count=(/1,jpan/) )
828         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xa_ed (:,1)), start=(/1,1/), count=(/1,jpan/) )
829         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xa_ed (:,3)), start=(/2,1/), count=(/1,jpan/) )
830         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xa_ed (:,5)), start=(/3,1/), count=(/1,jpan/) )
831         CALL flioputv (il_ncid, 'src_grid_corner_lon', lon_180(xa_ed (:,8)), start=(/4,1/), count=(/1,jpan/) )
832         
833         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         yo_ed (:,1) , start=(/1,1/), count=(/1,jpon/) )
834         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         yo_ed (:,3) , start=(/2,1/), count=(/1,jpon/) )
835         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         yo_ed (:,5) , start=(/3,1/), count=(/1,jpon/) )
836         CALL flioputv (il_ncid, 'dst_grid_corner_lat',         yo_ed (:,8) , start=(/4,1/), count=(/1,jpon/) )
837         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xo_ed (:,1)), start=(/1,1/), count=(/1,jpon/) )
838         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xo_ed (:,3)), start=(/2,1/), count=(/1,jpon/) )
839         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xo_ed (:,5)), start=(/3,1/), count=(/1,jpon/) )
840         CALL flioputv (il_ncid, 'dst_grid_corner_lon', lon_180(xo_ed (:,8)), start=(/4,1/), count=(/1,jpon/) )
841
842         SELECT CASE ( TRIM(c_amsk) )
843         CASE ( 'ext' )
844            CALL flioputv (il_ncid, 'src_grid_imask'        , 1-o2amask_i_ext     )
845         CASE ( 'int' )
846            CALL flioputv (il_ncid, 'src_grid_imask'        , 1-o2amask_i_int     )
847         CASE ( 'full')
848            CALL flioputv (il_ncid, 'src_grid_imask'        , 0*(1-o2amask_i_int) )
849         END SELECT
850         
851         SELECT CASE ( TRIM (c_omsk) )
852         CASE ( 'noperio' )
853            CALL flioputv (il_ncid, 'dst_grid_imask'     , (1-iomskt)*(1-iomskp) )
854         CASE ( 'perio' )
855            CALL flioputv (il_ncid, 'dst_grid_imask'     , (1-iomskt)            )
856         END SELECT
857         
858         CALL flioputv (il_ncid, 'src_grid_area'      , xasrft )
859         CALL flioputv (il_ncid, 'dst_grid_area'      , xosrft )
860         IF (l_src_grid_frac) THEN
861            CALL flioputv (il_ncid, 'src_grid_frac'      , o2amask )
862         ELSE
863            CALL flioputv (il_ncid, 'src_grid_frac'      , o2amask*0.0_rl+1.0_rl )
864         ENDIF
865         IF (l_dst_grid_frac) THEN
866            SELECT CASE ( TRIM(c_omsk))
867            CASE ('noperio' )
868               CALL flioputv (il_ncid, 'dst_grid_frac'      , REAL ((1-iomskt)*(1-iomskp),KIND=rl) )
869            CASE ( 'perio' )
870               CALL flioputv (il_ncid, 'dst_grid_frac'      , REAL ((1-iomskt)           ,KIND=rl) )
871            END SELECT
872         ELSE
873            SELECT CASE ( TRIM(c_omsk))
874            CASE ('noperio' )
875               CALL flioputv (il_ncid, 'dst_grid_frac'      , REAL ( (1-0*iomskt)*(1-0*iomskp) ,KIND=rl) )
876            CASE ( 'perio' )
877               CALL flioputv (il_ncid, 'dst_grid_frac'      , REAL ( (1-0*iomskt)              ,KIND=rl) )
878            END SELECT
879         END IF
880         
881         CALL flioputv (il_ncid, 'dst_address'        , k_dst (1:num_links) )
882         CALL flioputv (il_ncid, 'src_address'        , k_src (1:num_links) )
883         CALL flioputv (il_ncid, 'remap_matrix '      , w_mct (1:num_wgts,1:num_links) )
884         
885         !!
886         CALL flioclo (il_ncid)
887      END IF
888      !!
889      !!
890      RETURN
891   END SUBROUTINE wri_weights_a2o
892END MODULE mod_wri_wei
Note: See TracBrowser for help on using the repository browser.