/[lmdze]/trunk/IOIPSL/Mathelp/decoop.f
ViewVC logotype

Contents of /trunk/IOIPSL/Mathelp/decoop.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 104 - (show annotations)
Thu Sep 4 10:05:52 2014 UTC (9 years, 8 months ago) by guez
File size: 7687 byte(s) 
Removed procedure sortvarc0. Called sortvarc with an additional
argument resetvarc instead. (Following LMDZ.) Moved current time
computations and some printing statements from sortvarc to
caldyn. Could then remove arguments itau and time_0 of sortvarc, and
could remove "use dynetat0". Better to keep "dynetat0.f" as a gcm-only
file.

Moved some variables from module ener to module sortvarc.

Split file "mathelp.f" into single-procedure files.

Removed unused argument nadv of adaptdt. Removed dimension arguments
of bernoui.

Removed unused argument nisurf of interfoce_lim. Changed the size of
argument lmt_sst of interfoce_lim from klon to knon. Removed case when
newlmt is false.

dynredem1 is called only once in each run, either ce0l or gcm. So
variable nb in call to nf95_put_var was always 1. Removed variable nb.

Removed dimension arguments of calcul_fluxs. Removed unused arguments
precip_rain, precip_snow, snow of calcul_fluxs. Changed the size of
all the arrays in calcul_fluxs from klon to knon.

Removed dimension arguments of fonte_neige. Changed the size of all
the arrays in fonte_neige from klon to knon.

Changed the size of arguments tsurf and tsurf_new of interfsurf_hq
from klon to knon. Changed the size of argument ptsrf of soil from
klon to knon.
1 module decoop_m
2
3 implicit none
4
5 contains
6
7 SUBROUTINE decoop (pstr, nbops_max, missing_val, opps, scal, nbops)
8
9 USE errioipsl, ONLY : histerr
10 use findsep_m, only: findsep
11
12 CHARACTER(LEN=80) :: pstr
13 INTEGER :: nbops_max, nbops
14 CHARACTER(LEN=7) :: opps(nbops_max)
15 REAL :: scal(nbops_max), missing_val
16
17 CHARACTER(LEN=1) :: f_char(2), s_char(2)
18 INTEGER :: nbsep, f_pos(2), s_pos(2)
19 CHARACTER(LEN=20) :: opp_str, scal_str
20 CHARACTER(LEN=80) :: str
21 INTEGER :: xpos, leng, ppos, epos, int_tmp
22 CHARACTER(LEN=3) :: tl, dl
23 CHARACTER(LEN=10) :: fmt
24
25 LOGICAL :: check = .FALSE., prio
26 CHARACTER(LEN=80), SAVE :: ops = '+ - * / ^'
27 CHARACTER(LEN=80), SAVE :: mima = 'min max'
28 CHARACTER(LEN=250), SAVE :: funcs = &
29 'sin cos tan asin acos atan exp log sqrt chs abs ' &
30 //'cels kelv deg rad gather scatter fill coll undef only ident'
31
32 !---------------------------------------------------------------------
33
34 IF (check) WRITE(*, '(2a)') ' decoop : Incoming string : ', pstr
35
36 nbops = 0
37 str = pstr
38
39 CALL findsep (str, nbsep, f_char, f_pos, s_char, s_pos)
40 IF (check) WRITE(*, *) 'decoop : Out of findsep', nbsep
41 DO WHILE (nbsep > 0)
42 xpos = INDEX(str, 'X')
43 leng = LEN_TRIM(str)
44 nbops = nbops+1
45 !--
46 IF (check) THEN
47 WRITE(*, *) 'decoop : str -->', str(1:leng)
48 WRITE(*, *) s_char(1), '-', f_char(1), '|', f_char(2), '-', s_char(2)
49 WRITE(*, *) s_pos(1), '-', f_pos(1), '|', f_pos(2), '-', s_pos(2)
50 ENDIF
51 !--
52 IF (nbops > nbops_max-1) THEN
53 CALL histerr(3, 'decoop', 'Expression too complex', str, ' ')
54 ENDIF
55 !--
56 IF (check) WRITE(*, *) 'decoop : --', nbops, ' ', str(1:leng)
57 !---
58 !-- Start the analysis of the syntax. 3 types of constructs
59 !-- are recognized. They are scanned sequentialy
60 !---
61 IF (nbsep == 1) THEN
62 IF (check) WRITE(*, *) 'decoop : Only one operation'
63 IF (INDEX(ops, f_char(1)) > 0) THEN
64 !------ Type : scal+X
65 IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
66 opp_str = f_char(1)//'I'
67 ELSE
68 opp_str = f_char(1)
69 ENDIF
70 scal_str = str(s_pos(1)+1:f_pos(1)-1)
71 str = 'X'
72 ELSE IF (INDEX(ops, f_char(2)) > 0) THEN
73 !------ Type : X+scal
74 opp_str = f_char(2)
75 scal_str = str(f_pos(2)+1:s_pos(2)-1)
76 str = 'X'
77 ELSE
78 CALL histerr(3, 'decoop', &
79 'Unknown operations of type X+scal', f_char(1), pstr)
80 ENDIF
81 ELSE
82 IF (check) WRITE(*, *) 'decoop : More complex operation'
83 IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN
84 !------ Type : sin(X)
85 opp_str = str(s_pos(1)+1:f_pos(1)-1)
86 scal_str = '?'
87 str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng)
88 ELSE IF ( (f_char(1) == '(' .AND. f_char(2) == ', ')&
89 .OR.(f_char(1) == ', ' .AND. f_char(2) == ')')) THEN
90 !------ Type : max(X, scal) or max(scal, X)
91 IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN
92 !-------- Type : max(X, scal)
93 opp_str = str(f_pos(1)-3:f_pos(1)-1)
94 scal_str = str(f_pos(2)+1:s_pos(2)-1)
95 str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng)
96 ELSE IF (f_char(1) == ', ' .AND. s_char(1) == '(') THEN
97 !-------- Type : max(scal, X)
98 opp_str = str(s_pos(1)-3:s_pos(1)-1)
99 scal_str = str(s_pos(1)+1:f_pos(1)-1)
100 str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng)
101 ELSE
102 CALL histerr(3, 'decoop', 'Syntax error 1', str, ' ')
103 ENDIF
104 ELSE
105 prio = (f_char(2) == '*').OR.(f_char(2) == '^')
106 IF ( (INDEX(ops, f_char(1)) > 0) &
107 .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN
108 !-------- Type : ... scal+X ...
109 IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
110 opp_str = f_char(1)//'I'
111 ELSE
112 opp_str = f_char(1)
113 ENDIF
114 scal_str = str(s_pos(1)+1:f_pos(1)-1)
115 str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng)
116 ELSE IF ( (INDEX(ops, f_char(2)) > 0) &
117 .AND.(f_pos(2)-xpos == 1) ) THEN
118 !-------- Type : ... X+scal ...
119 opp_str = f_char(2)
120 scal_str = str(f_pos(2)+1:s_pos(2)-1)
121 str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng)
122 ELSE
123 CALL histerr(3, 'decoop', 'Syntax error 2', str, ' ')
124 ENDIF
125 ENDIF
126 ENDIF
127 !---
128 IF (check) WRITE(*, *) 'decoop : Finished syntax, str = ', TRIM(str)
129 !---
130 !-- Now that the different components of the operation are identified
131 !-- we transform them into what is going to be used in the program
132 !---
133 IF (INDEX(scal_str, '?') > 0) THEN
134 IF (INDEX(funcs, opp_str(1:LEN_TRIM(opp_str))) > 0) THEN
135 opps(nbops) = opp_str(1:LEN_TRIM(opp_str))
136 scal(nbops) = missing_val
137 ELSE
138 CALL histerr(3, 'decoop', &
139 'Unknown function', opp_str(1:LEN_TRIM(opp_str)), ' ')
140 ENDIF
141 ELSE
142 leng = LEN_TRIM(opp_str)
143 IF (INDEX(mima, opp_str(1:leng)) > 0) THEN
144 opps(nbops) = 'fu'//opp_str(1:leng)
145 ELSE
146 IF (INDEX(opp_str(1:leng), '+') > 0) THEN
147 opps(nbops) = 'add'
148 ELSE IF (INDEX(opp_str(1:leng), '-I') > 0) THEN
149 opps(nbops) = 'subi'
150 ELSE IF (INDEX(opp_str(1:leng), '-') > 0) THEN
151 opps(nbops) = 'sub'
152 ELSE IF (INDEX(opp_str(1:leng), '*') > 0) THEN
153 opps(nbops) = 'mult'
154 ELSE IF (INDEX(opp_str(1:leng), '/') > 0) THEN
155 opps(nbops) = 'div'
156 ELSE IF (INDEX(opp_str(1:leng), '/I') > 0) THEN
157 opps(nbops) = 'divi'
158 ELSE IF (INDEX(opp_str(1:leng), '^') > 0) THEN
159 opps(nbops) = 'power'
160 ELSE
161 CALL histerr(3, 'decoop', &
162 'Unknown operation', opp_str(1:leng), ' ')
163 ENDIF
164 ENDIF
165 !-----
166 leng = LEN_TRIM(scal_str)
167 ppos = INDEX(scal_str, '.')
168 epos = INDEX(scal_str, 'e')
169 IF (epos == 0) epos = INDEX(scal_str, 'E')
170 !-----
171 !---- Try to catch a few errors
172 !-----
173 IF (INDEX(ops, scal_str) > 0) THEN
174 CALL histerr(3, 'decoop', &
175 'Strange scalar you have here ', scal_str, pstr)
176 ENDIF
177 IF (epos > 0) THEN
178 WRITE(tl, '(I3.3)') leng
179 WRITE(dl, '(I3.3)') epos-ppos-1
180 fmt='(e'//tl//'.'//dl//')'
181 READ(scal_str, fmt) scal(nbops)
182 ELSE IF (ppos > 0) THEN
183 WRITE(tl, '(I3.3)') leng
184 WRITE(dl, '(I3.3)') leng-ppos
185 fmt='(f'//tl//'.'//dl//')'
186 READ(scal_str, fmt) scal(nbops)
187 ELSE
188 WRITE(tl, '(I3.3)') leng
189 fmt = '(I'//tl//')'
190 READ(scal_str, fmt) int_tmp
191 scal(nbops) = REAL(int_tmp)
192 ENDIF
193 ENDIF
194 IF (check) WRITE(*, *) 'decoop : Finished interpretation'
195 CALL findsep(str, nbsep, f_char, f_pos, s_char, s_pos)
196 ENDDO
197
198 END SUBROUTINE decoop
199
200 end module decoop_m
  ViewVC Help
Powered by ViewVC 1.1.21