Changeset 1991 for vendors/IOIPSL/current/src/mathelp.f90

Timestamp:

2010-07-08T15:39:26+02:00 (14 years ago)

Author:

smasson

Message:

Load working_directory into vendors/IOIPSL/current.

File:

• vendors/IOIPSL/current/src/mathelp.f90 (modified) (12 diffs)

vendors/IOIPSL/current/src/mathelp.f90

@@ -1 +1 @@
 MODULE mathelp
 !-
-!$Id: mathelp.f90 440 2008-11-26 10:58:38Z bellier $
+!$Id: mathelp.f90 845 2009-12-10 16:26:03Z bellier $
 !-
 ! This software is governed by the CeCILL license
@@ -28 +28 @@
 CONTAINS
 !===
-SUBROUTINE buildop (str,ex_topps,topp,nbops_max, &
- &                  missing_val,opps,scal,nbops)
+SUBROUTINE buildop (c_str,ex_topps,topp,fill_val,opps,scal,nbops)
 !---------------------------------------------------------------------
 !- This subroutine decomposes the input string in the elementary
@@ -39 +38 @@
 !- INPUT
 !-
-!- str      : String containing the operations
-!- ex_toops : The time operations that can be expected
-!-            within the string
+!- c_str    : String containing the operations
+!- ex_toops : Time operations that can be expected within the string
+!- fill_val :
 !-
 !- OUTPUT
 !-
-!---------------------------------------------------------------------
-  IMPLICIT NONE
-!-
-  CHARACTER(LEN=80) :: str
-  CHARACTER(LEN=*) :: ex_topps
-  CHARACTER(LEN=7) :: topp
-  INTEGER :: nbops_max,nbops
-  CHARACTER(LEN=7) :: opps(nbops_max)
-  REAL :: scal(nbops_max),missing_val
-!-
-  CHARACTER(LEN=80) :: new_str
+!- topp   : Time operation
+!- opps   :
+!- scal   :
+!- nbops  :
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: c_str,ex_topps
+  CHARACTER(LEN=*),INTENT(OUT) :: topp
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps
+  REAL,INTENT(IN) :: fill_val
+  REAL,DIMENSION(:),INTENT(OUT) :: scal
+  INTEGER,INTENT(OUT) :: nbops
+!-
+  CHARACTER(LEN=LEN(c_str)) :: str,new_str
   INTEGER :: leng,ind_opb,ind_clb
 !-
@@ -62 +65 @@
   IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning'
 !-
+  str = c_str
   leng = LEN_TRIM(str)
   IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN
@@ -94 +98 @@
  &          ' buildop : Call decoop ',new_str,ind_opb,ind_clb
         ENDIF
-        CALL decoop (new_str,nbops_max,missing_val,opps,scal,nbops)
+        CALL decoop (new_str,fill_val,opps,scal,nbops)
       ELSE
         CALL ipslerr(3,'buildop', &
@@ -115 +119 @@
 END SUBROUTINE buildop
 !===
-SUBROUTINE decoop (pstr,nbops_max,missing_val,opps,scal,nbops)
-!---------------------------------------------------------------------
-  IMPLICIT NONE
-!-
-  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)
+SUBROUTINE decoop (pstr,fill_val,opps,scal,nbops)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: pstr
+  REAL,INTENT(IN) :: fill_val
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps
+  REAL,DIMENSION(:),INTENT(OUT) :: scal
+  INTEGER,INTENT(OUT) :: nbops
+!-
+  CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char
+  INTEGER,DIMENSION(2) :: f_pos,s_pos
   CHARACTER(LEN=20) :: opp_str,scal_str
-  CHARACTER(LEN=80) :: str
-  INTEGER :: xpos,leng,ppos,epos,int_tmp
+  CHARACTER(LEN=LEN(pstr)) :: str
+  INTEGER :: nbsep,nbops_max,xpos,leng,ppos,epos,int_tmp
   CHARACTER(LEN=3) :: tl,dl
   CHARACTER(LEN=10) :: fmt
@@ -134 +139 @@
   LOGICAL :: check = .FALSE.,prio
 !---------------------------------------------------------------------
-  IF (check) WRITE(*,'(2a)') ' decoop : Incoming string : ',pstr
-!-
-  nbops = 0
-  str = pstr
+  IF (check) WRITE(*,'(2A)') ' decoop : Incoming string : ',pstr
+!-
+  str = pstr; nbops = 0;
 !-
   CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos)
   IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep
+!-
+  nbops_max = min(SIZE(opps),SIZE(scal))
+!-
   DO WHILE (nbsep > 0)
+    IF (nbops >= nbops_max) THEN
+      CALL ipslerr(3,'decoop','Expression too complex',TRIM(str),' ')
+    ENDIF
+!--
     xpos = INDEX(str,'X')
     leng = LEN_TRIM(str)
@@ -147 +158 @@
 !--
     IF (check) THEN
-      WRITE(*,*) 'decoop : str -->',str(1:leng)
+      WRITE(*,*) 'decoop : str   -> ',TRIM(str)
+      WRITE(*,*) 'decoop : nbops -> ',nbops
       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 ipslerr(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
@@ -236 +242 @@
       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
+        scal(nbops) = fill_val
       ELSE
         CALL ipslerr(3,'decoop', &
@@ -313 +319 @@
   IMPLICIT NONE
 !-
-  CHARACTER(LEN=80) :: str
+  CHARACTER(LEN=*),INTENT(INOUT) :: str
   INTEGER :: nbsep
   CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char
   INTEGER,DIMENSION(2) :: f_pos,s_pos
 !-
-  CHARACTER(LEN=70) :: str_tmp
+  CHARACTER(LEN=10) :: str_tmp
   LOGICAL :: f_found,s_found
   INTEGER :: ind,xpos,leng,i
@@ -385 +391 @@
     WRITE(str_tmp,'("number :",I3)') nbsep
     CALL ipslerr(3,'findsep', &
- &    'How can I find that many separators',str_tmp,str)
+ &    'How can I find that many separators',str_tmp,TRIM(str))
   ENDIF
 !-
@@ -399 +405 @@
   IMPLICIT NONE
 !-
-  CHARACTER(LEN=80) :: str
+  CHARACTER(LEN=*),INTENT(INOUT) :: str
 !-
   INTEGER :: ind,leng,ic,it