IOIPSL/Mathelp/decoop.f90

module decoop_m

  implicit none

contains

  SUBROUTINE decoop (pstr, nbops_max, missing_val, opps, scal, nbops)

    USE errioipsl, ONLY : histerr
    use findsep_m, only: findsep

    CHARACTER(LEN=80) :: pstr
    INTEGER :: nbops_max, nbops
    CHARACTER(LEN=7) :: opps(nbops_max)
    REAL :: scal(nbops_max), missing_val

    CHARACTER(LEN=1) :: f_char(2), s_char(2)
    INTEGER :: nbsep, f_pos(2), s_pos(2)
    CHARACTER(LEN=20) :: opp_str, scal_str
    CHARACTER(LEN=80) :: str
    INTEGER :: xpos, leng, ppos, epos, int_tmp
    CHARACTER(LEN=3) :: tl, dl
    CHARACTER(LEN=10) :: fmt

    LOGICAL :: check = .FALSE., prio
    CHARACTER(LEN=80), SAVE :: ops = '+ - * / ^'
    CHARACTER(LEN=80), SAVE :: mima = 'min max'
    CHARACTER(LEN=250), SAVE :: funcs = &
         'sin cos tan asin acos atan exp log sqrt chs abs ' &
         //'cels kelv deg rad gather scatter fill coll undef only ident'

    !---------------------------------------------------------------------

    IF (check) WRITE(*, '(2a)') ' decoop : Incoming string : ', pstr

    nbops = 0
    str = pstr

    CALL findsep (str, nbsep, f_char, f_pos, s_char, s_pos)
    IF (check) WRITE(*, *) 'decoop : Out of findsep', nbsep
    DO WHILE (nbsep > 0)
       xpos = INDEX(str, 'X')
       leng = LEN_TRIM(str)
       nbops = nbops+1
       !--
       IF (check) THEN
          WRITE(*, *) 'decoop : str -->', str(1:leng)
          WRITE(*, *) s_char(1), '-', f_char(1), '|', f_char(2), '-', s_char(2)
          WRITE(*, *) s_pos(1), '-', f_pos(1), '|', f_pos(2), '-', s_pos(2)
       ENDIF
       !--
       IF (nbops > nbops_max-1) THEN
          CALL histerr(3, 'decoop', 'Expression too complex', str, ' ')
       ENDIF
       !--
       IF (check) WRITE(*, *) 'decoop : --', nbops, ' ', str(1:leng)
       !---
       !-- Start the analysis of the syntax. 3 types of constructs
       !-- are recognized.  They are scanned sequentialy
       !---
       IF (nbsep == 1) THEN
          IF (check) WRITE(*, *) 'decoop : Only one operation'
          IF (INDEX(ops, f_char(1)) > 0) THEN
             !------ Type : scal+X
             IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
                opp_str = f_char(1)//'I'
             ELSE
                opp_str = f_char(1)
             ENDIF
             scal_str = str(s_pos(1)+1:f_pos(1)-1)
             str = 'X'
          ELSE IF (INDEX(ops, f_char(2)) > 0) THEN
             !------ Type : X+scal
             opp_str = f_char(2)
             scal_str = str(f_pos(2)+1:s_pos(2)-1)
             str = 'X'
          ELSE
             CALL histerr(3, 'decoop', &
                  'Unknown operations of type X+scal', f_char(1), pstr)
          ENDIF
       ELSE
          IF (check) WRITE(*, *) 'decoop : More complex operation'
          IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN
             !------ Type : sin(X)
             opp_str = str(s_pos(1)+1:f_pos(1)-1)
             scal_str = '?'
             str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng)
          ELSE IF (    (f_char(1) == '(' .AND. f_char(2) == ', ')&
               .OR.(f_char(1) == ', ' .AND. f_char(2) == ')')) THEN
             !------ Type : max(X, scal) or max(scal, X)
             IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN
                !-------- Type : max(X, scal)
                opp_str = str(f_pos(1)-3:f_pos(1)-1)
                scal_str = str(f_pos(2)+1:s_pos(2)-1)
                str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng)
             ELSE IF (f_char(1) == ', ' .AND. s_char(1) == '(') THEN
                !-------- Type : max(scal, X)
                opp_str = str(s_pos(1)-3:s_pos(1)-1)
                scal_str = str(s_pos(1)+1:f_pos(1)-1)
                str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng)
             ELSE
                CALL histerr(3, 'decoop', 'Syntax error 1', str, ' ')
             ENDIF
          ELSE
             prio = (f_char(2) == '*').OR.(f_char(2) == '^')
             IF (     (INDEX(ops, f_char(1)) > 0) &
                  .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN
                !-------- Type : ... scal+X ...
                IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
                   opp_str = f_char(1)//'I'
                ELSE
                   opp_str = f_char(1)
                ENDIF
                scal_str = str(s_pos(1)+1:f_pos(1)-1)
                str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng)
             ELSE IF (     (INDEX(ops, f_char(2)) > 0) &
                  .AND.(f_pos(2)-xpos == 1) ) THEN
                !-------- Type : ... X+scal ...
                opp_str = f_char(2)
                scal_str = str(f_pos(2)+1:s_pos(2)-1)
                str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng)
             ELSE
                CALL histerr(3, 'decoop', 'Syntax error 2', str, ' ')
             ENDIF
          ENDIF
       ENDIF
       !---
       IF (check) WRITE(*, *) 'decoop : Finished syntax, str = ', TRIM(str)
       !---
       !-- Now that the different components of the operation are identified
       !-- we transform them into what is going to be used in the program
       !---
       IF (INDEX(scal_str, '?') > 0) THEN
          IF (INDEX(funcs, opp_str(1:LEN_TRIM(opp_str))) > 0) THEN
             opps(nbops) = opp_str(1:LEN_TRIM(opp_str))
             scal(nbops) =  missing_val
          ELSE
             CALL histerr(3, 'decoop', &
                  'Unknown function', opp_str(1:LEN_TRIM(opp_str)), ' ')
          ENDIF
       ELSE
          leng = LEN_TRIM(opp_str)
          IF (INDEX(mima, opp_str(1:leng)) > 0) THEN
             opps(nbops) = 'fu'//opp_str(1:leng)
          ELSE
             IF (INDEX(opp_str(1:leng), '+') > 0) THEN
                opps(nbops) = 'add'
             ELSE IF (INDEX(opp_str(1:leng), '-I') > 0) THEN
                opps(nbops) = 'subi'
             ELSE IF (INDEX(opp_str(1:leng), '-') > 0) THEN
                opps(nbops) = 'sub'
             ELSE IF (INDEX(opp_str(1:leng), '*') > 0) THEN
                opps(nbops) = 'mult'
             ELSE IF (INDEX(opp_str(1:leng), '/') > 0) THEN
                opps(nbops) = 'div'
             ELSE IF (INDEX(opp_str(1:leng), '/I') > 0) THEN
                opps(nbops) = 'divi'
             ELSE IF (INDEX(opp_str(1:leng), '^') > 0) THEN
                opps(nbops) = 'power'
             ELSE
                CALL histerr(3, 'decoop', &
                     'Unknown operation', opp_str(1:leng), ' ')
             ENDIF
          ENDIF
          !-----
          leng = LEN_TRIM(scal_str)
          ppos = INDEX(scal_str, '.')
          epos = INDEX(scal_str, 'e')
          IF (epos == 0) epos = INDEX(scal_str, 'E')
          !-----
          !---- Try to catch a few errors
          !-----
          IF (INDEX(ops, scal_str) > 0) THEN
             CALL histerr(3, 'decoop', &
                  'Strange scalar you have here ', scal_str, pstr)
          ENDIF
          IF (epos > 0) THEN
             WRITE(tl, '(I3.3)') leng
             WRITE(dl, '(I3.3)') epos-ppos-1
             fmt='(e'//tl//'.'//dl//')'
             READ(scal_str, fmt) scal(nbops)
          ELSE IF (ppos > 0) THEN
             WRITE(tl, '(I3.3)') leng
             WRITE(dl, '(I3.3)') leng-ppos
             fmt='(f'//tl//'.'//dl//')'
             READ(scal_str, fmt) scal(nbops)
          ELSE
             WRITE(tl, '(I3.3)') leng
             fmt = '(I'//tl//')'
             READ(scal_str, fmt) int_tmp
             scal(nbops) = REAL(int_tmp)
          ENDIF
       ENDIF
       IF (check) WRITE(*, *) 'decoop : Finished interpretation'
       CALL findsep(str, nbsep, f_char, f_pos, s_char, s_pos)
    ENDDO

  END SUBROUTINE decoop

end module decoop_m
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