Changeset 845

Timestamp:

12/10/09 17:26:03 (14 years ago)

Author:

bellier

Message:

Update to FORTRAN 90

Location:

IOIPSL/trunk/src

Files:

• histcom.f90 (modified) (15 diffs)
• mathelp.f90 (modified) (11 diffs)

IOIPSL/trunk/src/histcom.f90

@@ -88 +88 @@
   CHARACTER(LEN=80) :: title,std_name,fullop
   CHARACTER(LEN=7)  :: topp
-  CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopps
+  CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp
   REAL,DIMENSION(nbopp_max) :: scal
 !-External type (for R4/R8)
@@ -1158 +1158 @@
   CHARACTER(LEN=40) :: str40
   CHARACTER(LEN=10) :: str10
-  CHARACTER(LEN=80) :: tmp_str80
-  CHARACTER(LEN=7) :: tmp_topp,tmp_sopp(nbopp_max)
   CHARACTER(LEN=120) :: ex_topps
-  REAL :: tmp_scal(nbopp_max),un_an,un_jour,test_fopp,test_fwrt
+  REAL :: un_an,un_jour,test_fopp,test_fwrt
   INTEGER :: pos,buff_sz
   LOGICAL :: l_dbg
@@ -1211 +1209 @@
 !-
   W_F(pfileid)%W_V(iv)%fullop = popp
-  tmp_str80 = popp
   CALL buildop &
- &  (tmp_str80,ex_topps,tmp_topp,nbopp_max,missing_val, &
- &   tmp_sopp,tmp_scal,W_F(pfileid)%W_V(iv)%nbopp)
-!-
-  W_F(pfileid)%W_V(iv)%topp = tmp_topp
-  DO i=1,W_F(pfileid)%W_V(iv)%nbopp
-    W_F(pfileid)%W_V(iv)%sopps(i) = tmp_sopp(i)
-    W_F(pfileid)%W_V(iv)%scal(i) = tmp_scal(i)
-  ENDDO
+ &  (TRIM(popp),ex_topps,W_F(pfileid)%W_V(iv)%topp,missing_val, &
+ &   W_F(pfileid)%W_V(iv)%sopp,W_F(pfileid)%W_V(iv)%scal, &
+ &   W_F(pfileid)%W_V(iv)%nbopp)
 !-
 ! 1.2 If we have an even number of operations
 !     then we need to add identity
 !-
-  IF (    2*INT(W_F(pfileid)%W_V(iv)%nbopp/2.0) &
- &     == W_F(pfileid)%W_V(iv)%nbopp) THEN
+  IF ( MOD(W_F(pfileid)%W_V(iv)%nbopp,2) == 0) THEN
     W_F(pfileid)%W_V(iv)%nbopp = W_F(pfileid)%W_V(iv)%nbopp+1
-    W_F(pfileid)%W_V(iv)%sopps(W_F(pfileid)%W_V(iv)%nbopp) = 'ident'
+    W_F(pfileid)%W_V(iv)%sopp(W_F(pfileid)%W_V(iv)%nbopp) = 'ident'
     W_F(pfileid)%W_V(iv)%scal(W_F(pfileid)%W_V(iv)%nbopp) = missing_val
   ENDIF
@@ -1244 +1235 @@
   IF (l_dbg) THEN
     WRITE(*,*) "histdef : 2.0",pfileid,iv,W_F(pfileid)%W_V(iv)%nbopp, &
- &    W_F(pfileid)%W_V(iv)%sopps(1:W_F(pfileid)%W_V(iv)%nbopp), &
+ &    W_F(pfileid)%W_V(iv)%sopp(1:W_F(pfileid)%W_V(iv)%nbopp), &
  &    W_F(pfileid)%W_V(iv)%scal(1:W_F(pfileid)%W_V(iv)%nbopp)
   ENDIF
@@ -1348 +1339 @@
 !     which need bufferisation
 !-
-  IF (     (TRIM(tmp_topp) /= "inst") &
- &    .AND.(TRIM(tmp_topp) /= "once") &
- &    .AND.(TRIM(tmp_topp) /= "never") )THEN
+  IF (     (TRIM(W_F(pfileid)%W_V(iv)%topp) /= "inst") &
+ &    .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= "once") &
+ &    .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= "never") )THEN
     W_F(pfileid)%W_V(iv)%point = buff_pos+1
     buff_pos = buff_pos+buff_sz
@@ -1410 +1401 @@
 !     its compaticility with the choice of frequencies
 !-
-  IF (TRIM(tmp_topp) == "inst") THEN
+  IF (TRIM(W_F(pfileid)%W_V(iv)%topp) == "inst") THEN
     IF (test_fopp /= test_fwrt) THEN
       str70 = 'For instantaneous output the frequency '// &
@@ -1427 +1418 @@
       ENDIF
     ENDIF
-  ELSE IF (INDEX(ex_topps,TRIM(tmp_topp)) > 0) THEN
+  ELSE IF (INDEX(ex_topps,TRIM(W_F(pfileid)%W_V(iv)%topp)) > 0) THEN
     IF (test_fopp > test_fwrt) THEN
       str70 = 'For averages the frequency of operations '// &
-&             'should be smaller or equal'
+ &            'should be smaller or equal'
       WRITE(str71, &
  &     '("to that of output. It is not the case for variable ",a)') &
@@ -1439 +1430 @@
     ENDIF
   ELSE
-    WRITE (str70,'("Operation on variable ",a," is unknown")') &
-&    TRIM(tmp_name)
-    WRITE (str71,'("operation requested is :",a)') tmp_topp
+    WRITE (str70,'("Operation on variable ",A," is unknown")') &
+ &   TRIM(tmp_name)
+    WRITE (str71,'("operation requested is :",A)') &
+ &   W_F(pfileid)%W_V(iv)%topp
     WRITE (str72,'("File ID :",I3)') pfileid
     CALL ipslerr (3,"histdef",str70,str71,str72)
@@ -1478 +1470 @@
   IF (W_F(pfileid)%W_V(iv)%freq_wrt > 0) THEN
     WRITE(str10,'(I8.8)') INT(W_F(pfileid)%W_V(iv)%freq_wrt)
-    str40 = TRIM(tmp_topp)//"_"//TRIM(str10)
+    str40 = TRIM(W_F(pfileid)%W_V(iv)%topp)//"_"//TRIM(str10)
   ELSE
     WRITE(str10,'(I2.2,"month")') ABS(INT(W_F(pfileid)%W_V(iv)%freq_wrt))
-    str40 = TRIM(tmp_topp)//"_"//TRIM(str10)
+    str40 = TRIM(W_F(pfileid)%W_V(iv)%topp)//"_"//TRIM(str10)
   ENDIF
   CALL find_str (W_F(pfileid)%W_V(1:W_F(pfileid)%n_tax)%tax_name,str40,pos)
@@ -1487 +1479 @@
 ! No time axis for once, l_max, l_min or never operation
 !-
-  IF (     (TRIM(tmp_topp) /= 'once')  &
- &    .AND.(TRIM(tmp_topp) /= 'never') &
- &    .AND.(TRIM(tmp_topp) /= 'l_max') &
- &    .AND.(TRIM(tmp_topp) /= 'l_min') ) THEN
+  IF (     (TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'once')  &
+ &    .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'never') &
+ &    .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'l_max') &
+ &    .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'l_min') ) THEN
     IF (pos < 0) THEN
       W_F(pfileid)%n_tax = W_F(pfileid)%n_tax+1
@@ -1500 +1492 @@
     ENDIF
   ELSE
-    IF (l_dbg)   WRITE(*,*) "histdef : 7.0 ",TRIM(tmp_topp),'----'
+    IF (l_dbg) THEN
+      WRITE(*,*) "histdef : 7.0 ",TRIM(W_F(pfileid)%W_V(iv)%topp),'----'
+    ENDIF
     W_F(pfileid)%W_V(iv)%t_axid = -99
   ENDIF
@@ -1507 +1501 @@
 !     for never or once operation
 !-
-  IF (    (TRIM(tmp_topp) == 'once')  &
- &    .OR.(TRIM(tmp_topp) == 'never') ) THEN
+  IF (    (TRIM(W_F(pfileid)%W_V(iv)%topp) == 'once')  &
+ &    .OR.(TRIM(W_F(pfileid)%W_V(iv)%topp) == 'never') ) THEN
     W_F(pfileid)%W_V(iv)%freq_opp = 0.
     W_F(pfileid)%W_V(iv)%freq_wrt = 0.
@@ -1896 +1890 @@
       largebuf = .FALSE.
       DO io=1,W_F(pfileid)%W_V(varid)%nbopp
-        IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopps(io)) > 0) THEN
+        IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopp(io)) > 0) THEN
           largebuf = .TRUE.
         ENDIF
@@ -1948 +1942 @@
     IF      (l1d) THEN
       nbpt_in1 = W_F(pfileid)%W_V(varid)%datasz_in(1)
-      CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in1,pdata_1d, &
+      CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in1,pdata_1d, &
  &                 missing_val,nbindex,nindex, &
  &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)
     ELSE IF (l2d) THEN
       nbpt_in2(1:2) = W_F(pfileid)%W_V(varid)%datasz_in(1:2)
-      CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in2,pdata_2d, &
+      CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in2,pdata_2d, &
  &                 missing_val,nbindex,nindex, &
  &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)
     ELSE IF (l3d) THEN
       nbpt_in3(1:3) = W_F(pfileid)%W_V(varid)%datasz_in(1:3)
-      CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in3,pdata_3d, &
+      CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in3,pdata_3d, &
  &                 missing_val,nbindex,nindex, &
  &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp)
@@ -2090 +2084 @@
       nbin = nbout
       nbout = W_F(i)%W_V(varid)%datasz_max
-      CALL mathop(W_F(i)%W_V(varid)%sopps(io),nbin,buff_tmp, &
+      CALL mathop(W_F(i)%W_V(varid)%sopp(io),nbin,buff_tmp, &
  &      missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io), &
  &      nbout,buff_tmp2)
       IF (l_dbg) THEN
         WRITE(*,*) &
- &       "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io)
+ &       "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp(io)
       ENDIF
 !-
       nbin = nbout
       nbout = W_F(i)%W_V(varid)%datasz_max
-      CALL mathop(W_F(i)%W_V(varid)%sopps(io+1),nbin,buff_tmp2, &
+      CALL mathop(W_F(i)%W_V(varid)%sopp(io+1),nbin,buff_tmp2, &
  &      missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io+1), &
  &      nbout,buff_tmp)
       IF (l_dbg) THEN
         WRITE(*,*) &
- &     "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io+1)
+ &     "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp(io+1)
       ENDIF
     ENDDO

IOIPSL/trunk/src/mathelp.f90

@@ -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