/[lmdze]/trunk/Sources/IOIPSL/mathop.f
ViewVC logotype

Annotation of /trunk/Sources/IOIPSL/mathop.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 178 - (hide annotations)
Fri Mar 11 18:47:26 2016 UTC (8 years, 3 months ago) by guez
File size: 18509 byte(s) 
Moved variables date0, deltat, datasz_max, ncvar_ids, point, buff_pos,
buffer, regular from module histcom_var to modules where they are
defined.

Removed procedure ioipslmpp, useless for a sequential program.

Added argument datasz_max to histwrite_real (to avoid circular
dependency with histwrite).

Removed useless variables and computations everywhere.

Changed real litteral constants from default kind to double precision
in lwb, lwu, lwvn, sw1s, swtt, swtt1, swu.

Removed unused arguments: paer of sw, sw1s, sw2s, swclr; pcldsw of
sw1s, sw2s; pdsig, prayl of swr; co2_ppm of clmain, clqh; tsol of
transp_lay; nsrf of screenp; kcrit and kknu of gwstress; pstd of
orosetup.

Added output of relative humidity.
1 guez 32 MODULE mathop_m
2    
3     ! From mathelp.f90, version 2.0 2004/04/05 14:47:50
4    
5     implicit none
6    
7     PRIVATE
8 guez 67 PUBLIC mathop
9 guez 32
10     INTERFACE mathop
11     MODULE PROCEDURE mathop_r11, mathop_r21, mathop_r31
12 guez 62 END INTERFACE mathop
13 guez 32
14 guez 62 ! Variables used to detect and identify the operations
15     CHARACTER(LEN=120):: indexfu = 'gather, scatter, fill, coll, undef, only'
16 guez 32
17     CONTAINS
18    
19 guez 62 SUBROUTINE mathop_r11(fun, nb, work_in, miss_val, nb_index, nindex, scal, &
20     nb_max, work_out)
21 guez 32
22 guez 62 ! This subroutine gives an interface to the various operations
23     ! which are allowed. The interface is general enough to allow its
24     ! use for other cases.
25 guez 32
26 guez 62 ! INPUT
27 guez 32
28 guez 62 ! fun : function to be applied to the vector of data
29     ! nb : Length of input vector
30     ! work_in : Input vector of data (REAL)
31     ! miss_val : The value of the missing data flag (it has to be a
32     ! maximum value, in f90 : huge( a real ))
33     ! nb_index : Length of index vector
34     ! nindex : Vector of indices
35     ! scal : A scalar value for vector/scalar operations
36     ! nb_max : maximum length of output vector
37 guez 32
38 guez 62 ! OUTPUT
39    
40     ! nb_max : Actual length of output variable
41     ! work_out : Output vector after the operation was applied
42 guez 32 USE errioipsl, ONLY : histerr
43 guez 62 USE mathop2, ONLY : ma_abs_r11, ma_acos_r11, ma_add_r11, ma_alog_r11, &
44     ma_asin_r11, ma_atan_r11, ma_cels_r11, ma_chs_r11, ma_cos_r11, &
45     ma_deg_r11, ma_divi_r11, ma_div_r11, ma_exp_r11, ma_fucoll_r11, &
46     ma_fufill_r11, ma_fugath_r11, ma_fumax_r11, ma_fumin_r11, &
47     ma_fuonly_r11, ma_fuscat_r11, ma_fuundef_r11, ma_ident_r11, &
48     ma_kelv_r11, ma_mult_r11, ma_power_r11, ma_rad_r11, ma_sin_r11, &
49     ma_sqrt_r11, ma_subi_r11, ma_sub_r11, ma_tan_r11
50 guez 32
51     CHARACTER(LEN=7) :: fun
52     INTEGER :: nb, nb_max, nb_index
53     INTEGER :: nindex(nb_index)
54     REAL :: work_in(nb), scal, miss_val
55     REAL :: work_out(nb_max)
56    
57     INTEGER :: ierr
58    
59 guez 62 !--------------------------------------------------------------------
60 guez 32 ierr = 0
61    
62     IF (scal >= miss_val-1.) THEN
63     IF (INDEX(indexfu, fun(1:LEN_TRIM(fun))) == 0) THEN
64     SELECT CASE (fun)
65     CASE('sin')
66     ierr = ma_sin_r11(nb, work_in, nb_max, work_out)
67     CASE('cos')
68     ierr = ma_cos_r11(nb, work_in, nb_max, work_out)
69     CASE('tan')
70     ierr = ma_tan_r11(nb, work_in, nb_max, work_out)
71     CASE('asin')
72     ierr = ma_asin_r11(nb, work_in, nb_max, work_out)
73     CASE('acos')
74     ierr = ma_acos_r11(nb, work_in, nb_max, work_out)
75     CASE('atan')
76     ierr = ma_atan_r11(nb, work_in, nb_max, work_out)
77     CASE('exp')
78     ierr = ma_exp_r11(nb, work_in, nb_max, work_out)
79     CASE('log')
80     ierr = ma_alog_r11(nb, work_in, nb_max, work_out)
81     CASE('sqrt')
82     ierr = ma_sqrt_r11(nb, work_in, nb_max, work_out)
83     CASE('chs')
84     ierr = ma_chs_r11(nb, work_in, nb_max, work_out)
85     CASE('abs')
86     ierr = ma_abs_r11(nb, work_in, nb_max, work_out)
87     CASE('cels')
88     ierr = ma_cels_r11(nb, work_in, nb_max, work_out)
89     CASE('kelv')
90     ierr = ma_kelv_r11(nb, work_in, nb_max, work_out)
91     CASE('deg')
92     ierr = ma_deg_r11(nb, work_in, nb_max, work_out)
93     CASE('rad')
94     ierr = ma_rad_r11(nb, work_in, nb_max, work_out)
95     CASE('ident')
96     ierr = ma_ident_r11(nb, work_in, nb_max, work_out)
97     CASE DEFAULT
98     CALL histerr(3, "mathop", &
99 guez 62 'scalar variable undefined and no indexing', &
100     'but still unknown function', fun)
101 guez 32 END SELECT
102     IF (ierr > 0) THEN
103     CALL histerr(3, "mathop", &
104 guez 62 'Error while executing a simple function', fun, ' ')
105 guez 32 ENDIF
106     ELSE
107     SELECT CASE (fun)
108     CASE('gather')
109     ierr = ma_fugath_r11(nb, work_in, nb_index, nindex, &
110 guez 62 miss_val, nb_max, work_out)
111 guez 32 CASE('scatter')
112     IF (nb_index > nb) THEN
113     work_out(1:nb_max) = miss_val
114     ierr=1
115     ELSE
116     ierr = ma_fuscat_r11(nb, work_in, nb_index, nindex, &
117 guez 62 miss_val, nb_max, work_out)
118 guez 32 ENDIF
119     CASE('coll')
120 guez 137 ierr = ma_fucoll_r11(nb, work_in, nb_index, nindex, nb_max, &
121     work_out)
122 guez 32 CASE('fill')
123 guez 137 ierr = ma_fufill_r11(nb, work_in, nb_index, nindex, nb_max, &
124     work_out)
125 guez 32 CASE('undef')
126     ierr = ma_fuundef_r11(nb, work_in, nb_index, nindex, &
127 guez 62 miss_val, nb_max, work_out)
128 guez 32 CASE('only')
129     ierr = ma_fuonly_r11(nb, work_in, nb_index, nindex, &
130 guez 62 miss_val, nb_max, work_out)
131 guez 32 CASE DEFAULT
132     CALL histerr(3, "mathop", &
133 guez 62 'scalar variable undefined and indexing', &
134     'was requested but with unknown function', fun)
135 guez 32 END SELECT
136     IF (ierr > 0) THEN
137     CALL histerr(3, "mathop_r11", &
138 guez 62 'Error while executing an indexing function', fun, ' ')
139 guez 32 ENDIF
140     ENDIF
141     ELSE
142     SELECT CASE (fun)
143     CASE('fumin')
144     ierr = ma_fumin_r11(nb, work_in, scal, nb_max, work_out)
145     CASE('fumax')
146     ierr = ma_fumax_r11(nb, work_in, scal, nb_max, work_out)
147     CASE('add')
148     ierr = ma_add_r11(nb, work_in, scal, nb_max, work_out)
149     CASE('subi')
150     ierr = ma_subi_r11(nb, work_in, scal, nb_max, work_out)
151     CASE('sub')
152     ierr = ma_sub_r11(nb, work_in, scal, nb_max, work_out)
153     CASE('mult')
154     ierr = ma_mult_r11(nb, work_in, scal, nb_max, work_out)
155     CASE('div')
156     ierr = ma_div_r11(nb, work_in, scal, nb_max, work_out)
157     CASE('divi')
158     ierr = ma_divi_r11(nb, work_in, scal, nb_max, work_out)
159     CASE('power')
160     ierr = ma_power_r11(nb, work_in, scal, nb_max, work_out)
161     CASE DEFAULT
162     CALL histerr(3, "mathop", &
163 guez 62 'Unknown operation with a scalar', fun, ' ')
164 guez 32 END SELECT
165     IF (ierr > 0) THEN
166     CALL histerr(3, "mathop", &
167 guez 62 'Error while executing a scalar function', fun, ' ')
168 guez 32 ENDIF
169     ENDIF
170 guez 62 !-----------------------
171 guez 32 END SUBROUTINE mathop_r11
172 guez 62 !
173     SUBROUTINE mathop_r21(fun, nb, work_in, miss_val, nb_index, nindex, scal, &
174     nb_max, work_out)
175 guez 32
176 guez 62 ! This subroutines gives an interface to the various operations
177     ! which are allowed. The interface is general enough to allow its use
178     ! for other cases.
179 guez 32
180 guez 62 ! INPUT
181 guez 32
182 guez 62 ! fun : function to be applied to the vector of data
183     ! nb : Length of input vector
184     ! work_in : Input vector of data (REAL)
185     ! miss_val : The value of the missing data flag (it has to be a
186     ! maximum value, in f90 : huge( a real ))
187     ! nb_index : Length of index vector
188     ! nindex : Vector of indices
189     ! scal : A scalar value for vector/scalar operations
190     ! nb_max : maximum length of output vector
191 guez 32
192 guez 62 ! OUTPUT
193 guez 32
194 guez 62 ! nb_max : Actual length of output variable
195     ! work_out : Output vector after the operation was applied
196 guez 32 USE errioipsl, ONLY : histerr
197 guez 62 USE mathop2, ONLY : ma_abs_r21, ma_acos_r21, ma_add_r21, ma_alog_r21, &
198     ma_asin_r21, ma_atan_r21, ma_cels_r21, ma_chs_r21, ma_cos_r21, &
199     ma_deg_r21, ma_divi_r21, ma_div_r21, ma_exp_r21, ma_fucoll_r21, &
200     ma_fufill_r21, ma_fugath_r21, ma_fumax_r21, ma_fumin_r21, &
201     ma_fuonly_r21, ma_fuscat_r21, ma_fuundef_r21, ma_ident_r21, &
202     ma_kelv_r21, ma_mult_r21, ma_power_r21, ma_rad_r21, ma_sin_r21, &
203     ma_sqrt_r21, ma_subi_r21, ma_sub_r21, ma_tan_r21
204 guez 32
205     CHARACTER(LEN=7) :: fun
206     INTEGER :: nb(2), nb_max, nb_index
207     INTEGER :: nindex(nb_index)
208     REAL :: work_in(nb(1), nb(2)), scal, miss_val
209     REAL :: work_out(nb_max)
210    
211     INTEGER :: ierr
212    
213 guez 62 !--------------------------------------------------------------------
214 guez 32 ierr = 0
215    
216     IF (scal >= miss_val-1.) THEN
217     IF (INDEX(indexfu, fun(1:LEN_TRIM(fun))) == 0) THEN
218     SELECT CASE (fun)
219     CASE('sin')
220     ierr = ma_sin_r21(nb, work_in, nb_max, work_out)
221     CASE('cos')
222     ierr = ma_cos_r21(nb, work_in, nb_max, work_out)
223     CASE('tan')
224     ierr = ma_tan_r21(nb, work_in, nb_max, work_out)
225     CASE('asin')
226     ierr = ma_asin_r21(nb, work_in, nb_max, work_out)
227     CASE('acos')
228     ierr = ma_acos_r21(nb, work_in, nb_max, work_out)
229     CASE('atan')
230     ierr = ma_atan_r21(nb, work_in, nb_max, work_out)
231     CASE('exp')
232     ierr = ma_exp_r21(nb, work_in, nb_max, work_out)
233     CASE('log')
234     ierr = ma_alog_r21(nb, work_in, nb_max, work_out)
235     CASE('sqrt')
236     ierr = ma_sqrt_r21(nb, work_in, nb_max, work_out)
237     CASE('chs')
238     ierr = ma_chs_r21(nb, work_in, nb_max, work_out)
239     CASE('abs')
240     ierr = ma_abs_r21(nb, work_in, nb_max, work_out)
241     CASE('cels')
242     ierr = ma_cels_r21(nb, work_in, nb_max, work_out)
243     CASE('kelv')
244     ierr = ma_kelv_r21(nb, work_in, nb_max, work_out)
245     CASE('deg')
246     ierr = ma_deg_r21(nb, work_in, nb_max, work_out)
247     CASE('rad')
248     ierr = ma_rad_r21(nb, work_in, nb_max, work_out)
249     CASE('ident')
250     ierr = ma_ident_r21(nb, work_in, nb_max, work_out)
251     CASE DEFAULT
252     CALL histerr(3, "mathop", &
253 guez 62 'scalar variable undefined and no indexing', &
254     'but still unknown function', fun)
255 guez 32 END SELECT
256     IF (ierr > 0) THEN
257     CALL histerr(3, "mathop", &
258 guez 62 'Error while executing a simple function', fun, ' ')
259 guez 32 ENDIF
260     ELSE
261     SELECT CASE (fun)
262     CASE('gather')
263     ierr = ma_fugath_r21(nb, work_in, nb_index, nindex, &
264 guez 62 miss_val, nb_max, work_out)
265 guez 32 CASE('scatter')
266     IF (nb_index > (nb(1)*nb(2)) ) THEN
267     work_out(1:nb_max) = miss_val
268     ierr=1
269     ELSE
270     ierr = ma_fuscat_r21(nb, work_in, nb_index, nindex, &
271 guez 62 miss_val, nb_max, work_out)
272 guez 32 ENDIF
273     CASE('coll')
274 guez 137 ierr = ma_fucoll_r21(nb, work_in, nb_index, nindex, nb_max, &
275     work_out)
276 guez 32 CASE('fill')
277 guez 137 ierr = ma_fufill_r21(nb, work_in, nb_index, nindex, nb_max, &
278     work_out)
279 guez 32 CASE('undef')
280     ierr = ma_fuundef_r21(nb, work_in, nb_index, nindex, &
281 guez 62 miss_val, nb_max, work_out)
282 guez 32 CASE('only')
283     ierr = ma_fuonly_r21(nb, work_in, nb_index, nindex, &
284 guez 62 miss_val, nb_max, work_out)
285 guez 32 CASE DEFAULT
286     CALL histerr(3, "mathop", &
287 guez 62 'scalar variable undefined and indexing', &
288     'was requested but with unknown function', fun)
289 guez 32 END SELECT
290     IF (ierr > 0) THEN
291     CALL histerr(3, "mathop_r21", &
292 guez 62 'Error while executing an indexing function', fun, ' ')
293 guez 32 ENDIF
294     ENDIF
295     ELSE
296     SELECT CASE (fun)
297     CASE('fumin')
298     ierr = ma_fumin_r21(nb, work_in, scal, nb_max, work_out)
299     CASE('fumax')
300     ierr = ma_fumax_r21(nb, work_in, scal, nb_max, work_out)
301     CASE('add')
302     ierr = ma_add_r21(nb, work_in, scal, nb_max, work_out)
303     CASE('subi')
304     ierr = ma_subi_r21(nb, work_in, scal, nb_max, work_out)
305     CASE('sub')
306     ierr = ma_sub_r21(nb, work_in, scal, nb_max, work_out)
307     CASE('mult')
308     ierr = ma_mult_r21(nb, work_in, scal, nb_max, work_out)
309     CASE('div')
310     ierr = ma_div_r21(nb, work_in, scal, nb_max, work_out)
311     CASE('divi')
312     ierr = ma_divi_r21(nb, work_in, scal, nb_max, work_out)
313     CASE('power')
314     ierr = ma_power_r21(nb, work_in, scal, nb_max, work_out)
315     CASE DEFAULT
316     CALL histerr(3, "mathop", &
317 guez 62 'Unknown operation with a scalar', fun, ' ')
318 guez 32 END SELECT
319     IF (ierr > 0) THEN
320     CALL histerr(3, "mathop", &
321 guez 62 'Error while executing a scalar function', fun, ' ')
322 guez 32 ENDIF
323     ENDIF
324 guez 62 !-----------------------
325 guez 32 END SUBROUTINE mathop_r21
326 guez 62 !
327     SUBROUTINE mathop_r31(fun, nb, work_in, miss_val, nb_index, nindex, scal, &
328     nb_max, work_out)
329 guez 32
330 guez 62 ! This subroutines gives an interface to the various operations
331     ! which are allowed. The interface is general enough to allow its use
332     ! for other cases.
333 guez 32
334 guez 62 ! INPUT
335 guez 32
336 guez 62 ! fun : function to be applied to the vector of data
337     ! nb : Length of input vector
338     ! work_in : Input vector of data (REAL)
339     ! miss_val : The value of the missing data flag (it has to be a
340     ! maximum value, in f90 : huge( a real ))
341     ! nb_index : Length of index vector
342     ! nindex : Vector of indices
343     ! scal : A scalar value for vector/scalar operations
344     ! nb_max : maximum length of output vector
345 guez 32
346 guez 62 ! OUTPUT
347 guez 32
348 guez 62 ! nb_max : Actual length of output variable
349     ! work_out : Output vector after the operation was applied
350 guez 32 USE errioipsl, ONLY : histerr
351 guez 62 USE mathop2, ONLY : ma_abs_r31, ma_acos_r31, ma_add_r31, ma_alog_r31, &
352     ma_asin_r31, ma_atan_r31, ma_cels_r31, ma_chs_r31, ma_cos_r31, &
353     ma_deg_r31, ma_divi_r31, ma_div_r31, ma_exp_r31, ma_fucoll_r31, &
354     ma_fufill_r31, ma_fugath_r31, ma_fumax_r31, ma_fumin_r31, &
355     ma_fuonly_r31, ma_fuscat_r31, ma_fuundef_r31, ma_ident_r31, &
356     ma_kelv_r31, ma_mult_r31, ma_power_r31, ma_rad_r31, ma_sin_r31, &
357     ma_sqrt_r31, ma_subi_r31, ma_sub_r31, ma_tan_r31
358 guez 32
359     CHARACTER(LEN=7) :: fun
360     INTEGER :: nb(3), nb_max, nb_index
361     INTEGER :: nindex(nb_index)
362     REAL :: work_in(nb(1), nb(2), nb(3)), scal, miss_val
363     REAL :: work_out(nb_max)
364    
365     INTEGER :: ierr
366    
367 guez 62 !--------------------------------------------------------------------
368 guez 32 ierr = 0
369    
370     IF (scal >= miss_val-1.) THEN
371     IF (INDEX(indexfu, fun(1:LEN_TRIM(fun))) == 0) THEN
372     SELECT CASE (fun)
373     CASE('sin')
374     ierr = ma_sin_r31(nb, work_in, nb_max, work_out)
375     CASE('cos')
376     ierr = ma_cos_r31(nb, work_in, nb_max, work_out)
377     CASE('tan')
378     ierr = ma_tan_r31(nb, work_in, nb_max, work_out)
379     CASE('asin')
380     ierr = ma_asin_r31(nb, work_in, nb_max, work_out)
381     CASE('acos')
382     ierr = ma_acos_r31(nb, work_in, nb_max, work_out)
383     CASE('atan')
384     ierr = ma_atan_r31(nb, work_in, nb_max, work_out)
385     CASE('exp')
386     ierr = ma_exp_r31(nb, work_in, nb_max, work_out)
387     CASE('log')
388     ierr = ma_alog_r31(nb, work_in, nb_max, work_out)
389     CASE('sqrt')
390     ierr = ma_sqrt_r31(nb, work_in, nb_max, work_out)
391     CASE('chs')
392     ierr = ma_chs_r31(nb, work_in, nb_max, work_out)
393     CASE('abs')
394     ierr = ma_abs_r31(nb, work_in, nb_max, work_out)
395     CASE('cels')
396     ierr = ma_cels_r31(nb, work_in, nb_max, work_out)
397     CASE('kelv')
398     ierr = ma_kelv_r31(nb, work_in, nb_max, work_out)
399     CASE('deg')
400     ierr = ma_deg_r31(nb, work_in, nb_max, work_out)
401     CASE('rad')
402     ierr = ma_rad_r31(nb, work_in, nb_max, work_out)
403     CASE('ident')
404     ierr = ma_ident_r31(nb, work_in, nb_max, work_out)
405     CASE DEFAULT
406     CALL histerr(3, "mathop", &
407 guez 62 'scalar variable undefined and no indexing', &
408     'but still unknown function', fun)
409 guez 32 END SELECT
410     IF (ierr > 0) THEN
411     CALL histerr(3, "mathop", &
412 guez 62 'Error while executing a simple function', fun, ' ')
413 guez 32 ENDIF
414     ELSE
415     SELECT CASE (fun)
416     CASE('gather')
417     ierr = ma_fugath_r31(nb, work_in, nb_index, nindex, &
418 guez 62 miss_val, nb_max, work_out)
419 guez 32 CASE('scatter')
420     IF (nb_index > (nb(1)*nb(2)*nb(3))) THEN
421     work_out(1:nb_max) = miss_val
422     ierr=1
423     ELSE
424     ierr = ma_fuscat_r31(nb, work_in, nb_index, nindex, &
425 guez 62 miss_val, nb_max, work_out)
426 guez 32 ENDIF
427     CASE('coll')
428 guez 137 ierr = ma_fucoll_r31(nb, work_in, nb_index, nindex, nb_max, &
429     work_out)
430 guez 32 CASE('fill')
431 guez 137 ierr = ma_fufill_r31(nb, work_in, nb_index, nindex, nb_max, &
432     work_out)
433 guez 32 CASE('undef')
434     ierr = ma_fuundef_r31(nb, work_in, nb_index, nindex, &
435 guez 62 miss_val, nb_max, work_out)
436 guez 32 CASE('only')
437     ierr = ma_fuonly_r31(nb, work_in, nb_index, nindex, &
438 guez 62 miss_val, nb_max, work_out)
439 guez 32 CASE DEFAULT
440     CALL histerr(3, "mathop", &
441 guez 62 'scalar variable undefined and indexing', &
442     'was requested but with unknown function', fun)
443 guez 32 END SELECT
444     IF (ierr > 0) THEN
445     CALL histerr(3, "mathop_r31", &
446 guez 62 'Error while executing an indexing function', fun, ' ')
447 guez 32 ENDIF
448     ENDIF
449     ELSE
450     SELECT CASE (fun)
451     CASE('fumin')
452     ierr = ma_fumin_r31(nb, work_in, scal, nb_max, work_out)
453     CASE('fumax')
454     ierr = ma_fumax_r31(nb, work_in, scal, nb_max, work_out)
455     CASE('add')
456     ierr = ma_add_r31(nb, work_in, scal, nb_max, work_out)
457     CASE('subi')
458     ierr = ma_subi_r31(nb, work_in, scal, nb_max, work_out)
459     CASE('sub')
460     ierr = ma_sub_r31(nb, work_in, scal, nb_max, work_out)
461     CASE('mult')
462     ierr = ma_mult_r31(nb, work_in, scal, nb_max, work_out)
463     CASE('div')
464     ierr = ma_div_r31(nb, work_in, scal, nb_max, work_out)
465     CASE('divi')
466     ierr = ma_divi_r31(nb, work_in, scal, nb_max, work_out)
467     CASE('power')
468     ierr = ma_power_r31(nb, work_in, scal, nb_max, work_out)
469     CASE DEFAULT
470     CALL histerr(3, "mathop", &
471 guez 62 'Unknown operation with a scalar', fun, ' ')
472 guez 32 END SELECT
473     IF (ierr > 0) THEN
474     CALL histerr(3, "mathop", &
475 guez 62 'Error while executing a scalar function', fun, ' ')
476 guez 32 ENDIF
477     ENDIF
478 guez 62
479 guez 32 END SUBROUTINE mathop_r31
480    
481     END MODULE mathop_m
  ViewVC Help
Powered by ViewVC 1.1.21