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

Annotation of /trunk/Sources/IOIPSL/Mathelp/decoop.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 104 - (hide annotations)
Thu Sep 4 10:05:52 2014 UTC (9 years, 9 months ago) by guez
Original Path: trunk/IOIPSL/Mathelp/decoop.f
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 guez 104 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