source: branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/sechiba_io.f90 @ 257

Last change on this file since 257 was 257, checked in by didier.solyga, 13 years ago

Externalized version merged with the trunk
File size: 16.9 KB
Line 
1!! This subroutines initialize a variable or an array
2!! with a variable or an array of smaller rank
3!! - i is for integer interface - r for real interface
4!! - 0 is for a scalar - 1 for a 1D array - 2 for a 2D array
5!! Thee right routines is automatically called depending type of input variable
6!! This initialisation is done only if the value of input field is egal to val_exp
7!!
8!! If a key word is provided which is not equal to "NO_KEYWORD" or "NOKEYWORD" then
9!! we try to find the value to fill in in the configuration file.
10!!
11!! @author Marie-Alice Foujols and Jan Polcher
12!! @Version : $Revision: 12 $, $Date: 2010-11-05 16:42:13 +0100 (Fri, 05 Nov 2010) $
13!!
14!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/sechiba_io.f90 $
15!< $Date: 2010-11-05 16:42:13 +0100 (Fri, 05 Nov 2010) $
16!< $Author: mmaipsl $
17!< $Revision: 12 $
18!! IPSL (2006)
19!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
20!!
21MODULE sechiba_io
22
23  USE defprec
24  USE constantes
25  USE ioipsl
26  USE sechiba_io_p
27
28  IMPLICIT NONE
29
30  INTERFACE setvar
31    MODULE PROCEDURE i0setvar, i10setvar, i20setvar, i11setvar, i21setvar, i22setvar
32    MODULE PROCEDURE r0setvar, r10setvar, r20setvar, r11setvar, r21setvar, r22setvar, r30setvar
33  END INTERFACE
34
35!
36! mettre la l'interface des routines utilisees:
37!
38! restget/put/ini histbeg/def flinopen/close
39!
40
41LOGICAL, SAVE                  :: long_print_setvar=.FALSE.  !! change to true to have more information
42
43CONTAINS 
44
45
46!! Interface for integer scalar to scalar.
47SUBROUTINE i0setvar (var, val_exp, key_wd, val_put)
48
49  INTEGER(i_std), INTENT(inout)                   :: var                  !! Integer scalar to modify
50  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
51  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
52  INTEGER(i_std), INTENT(in)                      :: val_put              !! Initial value to stored
53
54  INTEGER(i_std)                                  :: val_tmp
55  INTEGER(i_std)                                  :: is_key
56
57  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
58 
59  IF (long_print_setvar) WRITE(numout,*) "i0setvar :", key_wd, val_exp, val_put
60
61  val_tmp = val_put
62
63  IF ( var == val_exp ) THEN
64     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
65     var = val_tmp
66  END IF
67 
68END SUBROUTINE i0setvar
69
70
71!! Interface for initialising an 1D integer array with a scalar integer.
72SUBROUTINE i10setvar (var, val_exp, key_wd, val_put)
73
74  INTEGER(i_std), DIMENSION(:), INTENT(inout)     :: var                  !! 1D integer array to modify
75  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
76  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
77  INTEGER(i_std), INTENT(in)                      :: val_put              !! Scalar value to stored
78 
79  INTEGER(i_std)                                  :: val_tmp
80  INTEGER(i_std)                                  :: is_key
81
82  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
83
84  IF (long_print_setvar) WRITE(numout,*) "i10setvar :", key_wd, val_exp, val_put
85
86  val_tmp = val_put
87
88  IF ( ALL( var(:) == val_exp ) ) THEN
89     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
90     var(:) = val_tmp
91  END IF
92 
93END SUBROUTINE i10setvar
94
95
96!! Interface for initialising an 1D array integer with an other 1D array integer.
97SUBROUTINE i11setvar (var, val_exp, key_wd, val_put)
98 
99  INTEGER(i_std), DIMENSION(:), INTENT(inout)     :: var                 !! 1D integer array to modify
100  INTEGER(i_std), INTENT(in)                      :: val_exp             !! Exceptional value
101  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
102  INTEGER(i_std), DIMENSION(:), INTENT(in)        :: val_put             !! 1D integer array to stored
103
104  INTEGER(i_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
105  INTEGER(i_std)                                  :: is_key
106
107  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
108 
109  IF (long_print_setvar) WRITE(numout,*) "i11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
110
111  ALLOCATE(val_tmp(SIZE(val_put)))
112  val_tmp(:) = val_put(:)
113
114  IF ( ALL( var(:) == val_exp ) ) THEN
115     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
116     var(:) = val_tmp (:)
117  END IF
118
119  DEALLOCATE(val_tmp)
120 
121END SUBROUTINE i11setvar
122
123
124!! Interface for initialising an 2D array integer with a scalar integer.
125SUBROUTINE i20setvar (var, val_exp, key_wd, val_put)
126 
127  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
128  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
129  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
130  INTEGER(i_std), INTENT(in)                      :: val_put              !! Scalar value to stored
131
132  INTEGER(i_std)                                  :: val_tmp
133  INTEGER(i_std)                                  :: is_key
134
135  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
136 
137  !
138  ! this subroutine set val_put value to var if var is constant
139  !
140  !
141  IF (long_print_setvar) WRITE(numout,*) "i20setvar :", key_wd, val_exp, val_put
142
143  val_tmp = val_put
144
145  IF ( ALL( var(:,:) == val_exp ) ) THEN
146     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
147     var(:,:) = val_tmp
148  END IF
149 
150END SUBROUTINE i20setvar
151
152
153!! Interface for initialising an 2D array integer with an 1D array integer.
154!! Row or column depending size of 1D array to stored.
155!!
156!! example: 1D 1,2,3     2D is 1, 2, 3,
157!!                             1, 2, 3
158!!
159!!
160!! example: 1D 1,2,3     2D is 1, 1,
161!!                             2, 2,
162!!                             3, 3
163!!
164SUBROUTINE i21setvar (var, val_exp, key_wd, val_put)
165 
166  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
167  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
168  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
169  INTEGER(i_std), DIMENSION(:), INTENT(in)        :: val_put              !! 1D integer array to stored
170 
171  INTEGER(i_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
172  INTEGER(i_std)                                  :: is_key
173
174  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
175
176  ! test if the 1D array dimension is compatible with first or second
177  ! dimension of the 2D array
178
179  IF (long_print_setvar) WRITE(numout,*) "i21setvar :", key_wd, val_exp, val_put
180
181  ALLOCATE(val_tmp(SIZE(val_put)))
182  val_tmp(:) = val_put(:)
183
184  IF (SIZE(val_put)==SIZE(var,1)) THEN 
185      !
186      ! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
187      !                                1., 2., 3.
188      !
189      IF ( ALL( var(:,:) == val_exp ) ) THEN
190         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
191         var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
192      END IF
193  ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN 
194      !
195      ! example: 1D 1.,2.,3.     2D is 1., 1.,
196      !                                2., 2.,
197      !                                3., 3.
198      !
199      IF ( ALL( var(:,:) == val_exp ) ) THEN
200         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
201         var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
202      END IF
203  ELSE
204      WRITE(numout,*) ' incompatible dimension var and val_put'
205      WRITE(numout,*) ' var     ', SIZE(var,1), SIZE(var,2)
206      WRITE(numout,*) ' val_put ', SIZE(val_put)
207      STOP 'setvar'
208  END IF
209
210  DEALLOCATE(val_tmp)
211 
212END SUBROUTINE i21setvar
213
214!! Interface for initialising an 2D array integer with an other 2D array integer.
215SUBROUTINE i22setvar (var, val_exp, key_wd, val_put)
216 
217  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                 !! 2D integer array to modify
218  INTEGER(i_std), INTENT(in)                      :: val_exp             !! Exceptional value
219  CHARACTER(LEN=*), INTENT(in)                :: key_wd              !! The Key word we will look for
220  INTEGER(i_std), DIMENSION(:,:), INTENT(in)      :: val_put             !! 2D integer array to stored
221
222  INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)     :: val_tmp
223  INTEGER(i_std)                                  :: is_key
224
225  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
226 
227  IF (long_print_setvar) WRITE(numout,*) "i21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
228
229  ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
230  val_tmp(:,:) = val_put(:,:)
231
232  IF ( ALL(var(:,:) == val_exp ) ) THEN
233     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
234     var(:,:) = val_tmp(:,:)
235  END IF
236
237  DEALLOCATE(val_tmp)
238 
239END SUBROUTINE i22setvar
240
241
242!! Interface for scalar to scalar real
243SUBROUTINE r0setvar (var, val_exp, key_wd, val_put)
244 
245  REAL(r_std), INTENT(inout)                   :: var                  !! Real scalar to modify
246  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
247  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
248  REAL(r_std), INTENT(in)                      :: val_put              !! Initial value to stored
249 
250  REAL(r_std)                                  :: val_tmp
251  INTEGER(i_std)                                     :: is_key
252
253  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
254
255  IF (long_print_setvar) WRITE(numout,*) "r0setvar :", key_wd, val_exp, val_put
256
257  val_tmp = val_put
258
259  IF ( var==val_exp ) THEN
260     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
261     var = val_tmp
262  END IF
263 
264END SUBROUTINE r0setvar
265
266
267!! Interface for initialising an 1D real array with a scalar real.
268SUBROUTINE r10setvar (var, val_exp, key_wd, val_put)
269 
270  REAL(r_std), DIMENSION(:), INTENT(inout)     :: var                  !! 1D real array to modify
271  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
272  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
273  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
274   
275  REAL(r_std)                                  :: val_tmp
276  INTEGER(i_std)                                     :: is_key
277
278  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
279 
280  IF (long_print_setvar) WRITE(numout,*) "r10setvar :", key_wd, val_exp, val_put
281
282  val_tmp = val_put
283
284  IF ( ALL( var(:) == val_exp ) ) THEN
285     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
286     var(:) = val_tmp
287  END IF
288 
289END SUBROUTINE r10setvar
290
291
292!! Interface for initialising an 1D array real with an other 1D array real.
293SUBROUTINE r11setvar (var, val_exp, key_wd, val_put)
294 
295  REAL(r_std), DIMENSION(:), INTENT(inout)     :: var                 !! 1D real array to modify
296  REAL(r_std), INTENT(in)                      :: val_exp             !! Exceptional value
297  CHARACTER(LEN=*), INTENT(in)                   :: key_wd              !! The Key word we will look for
298  REAL(r_std), DIMENSION(:), INTENT(in)        :: val_put             !! 1D integer array to stored
299
300  REAL(r_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
301  INTEGER(i_std)                                     :: is_key
302
303  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
304   
305  IF (long_print_setvar) WRITE(numout,*) "r11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
306
307  ALLOCATE(val_tmp(SIZE(val_put)))
308  val_tmp(:) = val_put(:)
309
310  IF ( ALL( var(:) == val_exp ) ) THEN
311     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
312     var(:) = val_tmp (:)
313  END IF
314
315  DEALLOCATE(val_tmp)
316 
317END SUBROUTINE r11setvar
318
319
320!! Interface for initialising an 2D array real with a scalar real.
321SUBROUTINE r20setvar (var, val_exp, key_wd, val_put)
322 
323  ! interface for scalar to 2D array real
324
325  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
326  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
327  CHARACTER(LEN=*), INTENT(in)                   :: key_wd                  !! The Key word we will look for
328  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
329 
330  REAL(r_std)                                  :: val_tmp 
331  INTEGER(i_std)                                     :: is_key
332
333  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
334 
335  IF (long_print_setvar) WRITE(numout,*) "r20setvar :", key_wd, val_exp, val_put
336
337  val_tmp = val_put
338
339  IF ( ALL( var(:,:) == val_exp ) ) THEN
340     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
341     var(:,:) = val_tmp
342  END IF
343 
344END SUBROUTINE r20setvar
345
346
347!! Interface for initialising an 2D array real with an 1D array real.
348!! Row or column depending size of 1D array to stored.
349!!
350!! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
351!!                                1., 2., 3.
352!!
353!!
354!! example: 1D 1.,2.,3.     2D is 1., 1.,
355!!                                2., 2.,
356!!                                3., 3.
357!!
358SUBROUTINE r21setvar (var, val_exp, key_wd, val_put)
359 
360  ! interface for 1D array to 2D array real
361
362  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D real array to modify
363  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
364  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
365  REAL(r_std), DIMENSION(:), INTENT(in)        :: val_put              !! 1D real array to stored
366
367  REAL(r_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
368  INTEGER(i_std)                                     :: is_key
369
370  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
371 
372  ! test if the 1D array dimension is compatible with first or second
373  ! dimension of the 2D array
374
375  IF (long_print_setvar) WRITE(numout,*) "r21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
376
377  ALLOCATE(val_tmp(SIZE(val_put)))
378  val_tmp(:) = val_put(:)
379
380  IF (SIZE(val_put)==SIZE(var,1)) THEN 
381      !
382      ! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
383      !                                1., 2., 3.
384      !
385      IF ( ALL( var(:,:) == val_exp ) ) THEN
386         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
387         var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
388      END IF
389  ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN 
390      !
391      ! example: 1D 1.,2.,3.     2D is 1., 1.,
392      !                                2., 2.,
393      !                                3., 3.
394      !
395      IF ( ALL( var(:,:) == val_exp ) ) THEN
396         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
397         var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
398      END IF
399  ELSE
400      WRITE(numout,*) ' incompatible dimension var and val_put'
401      WRITE(numout,*) ' var     ', SIZE(var,1), SIZE(var,2)
402      WRITE(numout,*) ' val_put ', SIZE(val_put)
403      STOP 'setvar'
404  END IF
405
406  DEALLOCATE(val_tmp)
407 
408END SUBROUTINE r21setvar
409
410
411!! Interface for initialising an 2D array real with an other 2D array real.
412SUBROUTINE r22setvar (var, val_exp, key_wd, val_put)
413 
414  ! interface for 2D array to 2D array real
415
416  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                 !! 2D real array to modify
417  REAL(r_std), INTENT(in)                      :: val_exp             !! Exceptional value
418  CHARACTER(LEN=*), INTENT(in)                   :: key_wd              !! The Key word we will look for
419  REAL(r_std), DIMENSION(:,:), INTENT(in)      :: val_put             !! 2D integer array to stored
420
421  REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: val_tmp
422  INTEGER(i_std)                                     :: is_key
423
424  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
425
426  IF (long_print_setvar) WRITE(numout,*) "r22setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
427
428  ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
429  val_tmp(:,:) = val_put(:,:)
430
431  IF ( ALL( var(:,:) == val_exp ) ) THEN
432     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
433     var(:,:) = val_tmp(:,:)
434  END IF
435
436  DEALLOCATE(val_tmp)
437 
438END SUBROUTINE r22setvar
439
440!! Interface for initialising an 3D array real with a scalar real.
441SUBROUTINE r30setvar (var, val_exp, key_wd, val_put)
442
443  ! interface for scalar to 3D array real
444
445  REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: var                  !! 3D integer array to modify
446  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
447  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
448  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
449
450  REAL(r_std)                                  :: val_tmp 
451  INTEGER(i_std)                              :: is_key
452
453  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
454
455  IF (long_print_setvar) WRITE(numout,*) 'r30setvar',val_exp, val_put
456
457  val_tmp = val_put
458
459  IF ( ALL( var(:,:,:) == val_exp ) ) THEN
460     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
461     var(:,:,:) = val_tmp
462  END IF
463
464END SUBROUTINE r30setvar
465
466END MODULE sechiba_io
Note: See TracBrowser for help on using the repository browser.