Changeset 845 for IOIPSL/trunk/src/histcom.f90

Timestamp:

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

Author:

bellier

Message:

Update to FORTRAN 90

File:

• IOIPSL/trunk/src/histcom.f90 (modified) (15 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