Changeset 4863

Timestamp:

12/16/19 14:33:26 (4 years ago)

Author:

jgipsl

Message:

Following changes have been done by A.Jornet/LSCE. No change is results and no change in usage have been seen. Some more error checking might stop the model for example if dimensions are not correct in call to histcom module.

Restcom:

• Define a new var size length (20 to 100 )→ pbs found without no errors
• Raise an error when var name is too long
• Deallocate any buffer at the end of all restput/restcget calls → buffers only increase size. After loading/saving nothing is done with this memory

Histcom:

• Raise an error if given history declared variables do not match with given dimensions from histwrite

getincom and stringop:

• Enable any length character for the run.def → useful for long filepaths

flincom

• Enable filenames longer than 80 chars to any
• Deallocate buffers at the end of any flinget subroutine

Location:

IOIPSL/trunk/src

Files:

• flincom.f90 (modified) (8 diffs)
• getincom.f90 (modified) (8 diffs)
• histcom.f90 (modified) (2 diffs)
• restcom.f90 (modified) (19 diffs)
• stringop.f90 (modified) (2 diffs)

IOIPSL/trunk/src/flincom.f90

@@ -691 +691 @@
   INTEGER :: iv, lll
   INTEGER :: xid, yid, zid, tid
-  CHARACTER(LEN=80) :: name
+  CHARACTER(LEN=:), ALLOCATABLE :: name
   CHARACTER(LEN=30) :: axname
 !-
@@ -999 +999 @@
   ENDDO
 !-------------------------
+  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp)
 END SUBROUTINE flinget_r1d
 !-
@@ -1041 +1042 @@
   ENDDO
 !-------------------------
+  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp)
 END SUBROUTINE flinget_r2d
 !-
@@ -1083 +1085 @@
     ENDDO
   ENDDO
+  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp)
 !--------------------------------
 END SUBROUTINE flinget_r2d_zoom2d
@@ -1128 +1131 @@
   ENDDO
 !-------------------------
+  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp)
 END SUBROUTINE flinget_r3d
 !-
@@ -1173 +1177 @@
   ENDDO
 !--------------------------------
+  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp)
 END SUBROUTINE flinget_r3d_zoom2d
 !-
@@ -1219 +1224 @@
   ENDDO
 !-------------------------
+  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp)
 END SUBROUTINE flinget_r4d
 !-
@@ -1266 +1272 @@
   ENDDO
 !--------------------------------
+  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp)
 END SUBROUTINE flinget_r4d_zoom2d
 !-

IOIPSL/trunk/src/getincom.f90

@@ -8 +8 @@
 USE errioipsl, ONLY : ipslerr,ipsldbg,ipslout
 USE stringop, &
- &   ONLY : nocomma,cmpblank,strlowercase
+ &   ONLY : nocomma,cmpblank,strlowercase,nocomment, COMMENT_TAG
 !-
 IMPLICIT NONE
@@ -436 +436 @@
   CHARACTER(LEN=*) :: ret_val
 !-
-  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
-  INTEGER :: pos,status=0,fileorig,size_of_in
-!---------------------------------------------------------------------
+  CHARACTER(LEN=:),ALLOCATABLE,DIMENSION(:) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig,size_of_in,ier
+  INTEGER :: inlength
+!---------------------------------------------------------------------
+!-
+  inlength = LEN(ret_val)
+  ALLOCATE(CHARACTER(inlength) :: tmp_ret_val(1), stat=ier)
+  IF (ier /= 0) CALL ipslerr(3, 'getincs', 'Allocation memory problem for', &
+                             'tmp_ret_val' ,'')
 !-
 ! Do we have this targetname in our database ?
@@ -458 +464 @@
   ENDIF
   ret_val = tmp_ret_val(1)
+!--
+  DEALLOCATE(tmp_ret_val)
 !---------------------
 END SUBROUTINE getincs
@@ -717 +725 @@
   INTEGER :: k_typ,it,pos,len_str,status_cnt,io_err
   CHARACTER(LEN=n_d_fmt)  :: cnt
-  CHARACTER(LEN=80) :: str_READ,str_READ_lower
+  CHARACTER(LEN=:), ALLOCATABLE :: str_READ,str_READ_lower
   CHARACTER(LEN=9)  :: c_vtyp
   LOGICAL,DIMENSION(:),ALLOCATABLE :: found
@@ -1123 +1131 @@
   INTEGER :: current
 !-
-  CHARACTER(LEN=300) :: READ_str,NEW_str,last_key,key_str
+  CHARACTER(LEN=:), ALLOCATABLE :: READ_str, NEW_str
+  CHARACTER(LEN=300) :: last_key,key_str
   CHARACTER(LEN=n_d_fmt) :: cnt
   CHARACTER(LEN=10) :: c_fmt
@@ -1262 +1271 @@
 !-
   INTEGER :: len_str,blk,nbve,starpos
-  CHARACTER(LEN=300) :: tmp_str,new_key,mult
+  CHARACTER(LEN=:), ALLOCATABLE :: tmp_str,new_key,mult
   CHARACTER(LEN=n_d_fmt) :: cnt
   CHARACTER(LEN=10) :: c_fmt
@@ -1488 +1497 @@
 !===
 !-
-SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
-!---------------------------------------------------------------------
-  IMPLICIT NONE
-!-
-  INTEGER :: unit,eof,nb_lastkey
-  CHARACTER(LEN=300) :: dummy
-  CHARACTER(LEN=300),INTENT(out) :: out_string
+SUBROUTINE getin_readline(unitf, out_string, is_eof)
+!---------------------------------------------------------------------
+  USE ISO_FORTRAN_ENV,ONLY : IOSTAT_EOR,IOSTAT_END
+!-
+  IMPLICIT NONE
+!-
+  INTEGER, PARAMETER :: CHARLEN = 100     ! buffer size
+  INTEGER, INTENT(in) :: unitf
+  INTEGER, INTENT(out) :: is_eof
+  CHARACTER(LEN=:),INTENT(out),ALLOCATABLE :: out_string
+!-
+  CHARACTER(LEN=CHARLEN)  :: dummy
+!-
+  CHARACTER(LEN=:), ALLOCATABLE :: buff1  ! buffer
+  INTEGER :: ioerr                  ! error code
+  INTEGER :: readlength                   ! number of chars read from file 
+  LOGICAL :: is_eol, is_first_ite         ! end of line? 
+
+  is_eof = 0
+  is_eol = .FALSE.
+  buff1 = ""
+
+  DO WHILE (.NOT. is_eol)
+!-
+      dummy = ""
+      READ (UNIT=unitf,FMT='(A)', ADVANCE='NO', SIZE=readlength,ERR=9998,END=7778,IOSTAT=ioerr) dummy
+      IF ((ioerr==IOSTAT_EOR).OR.(ioerr==IOSTAT_END)) ioerr = 0
+!-
+      ! keep looping if line is commented
+      dummy = TRIM(ADJUSTL(dummy))
+!-
+      ! is end of line?
+      is_eol = (readlength .LT. CHARLEN)
+!-
+      ! merge with previous buffer
+      buff1 = TRIM(buff1)//TRIM(dummy)
+  ENDDO
+!-
+  out_string=TRIM(buff1)
+!-
+  RETURN
+!-
+9998 CONTINUE
+  CALL ipslerr (3,'getin_readline','Error while reading file',' ',' ')
+!-
+7778 CONTINUE
+  out_string = TRIM(dummy)
+  is_eof = 1
+    
+END SUBROUTINE getin_readline
+!-
+! getin_skipafew: reads  
+!-
+SUBROUTINE getin_skipafew (unit,out_string,is_eof,nb_lastkey)
+!---------------------------------------------------------------------
+  USE ISO_FORTRAN_ENV,ONLY : IOSTAT_EOR,IOSTAT_END
+!-
+  IMPLICIT NONE
+!-
+  INTEGER :: unit,is_eof,nb_lastkey
+  CHARACTER(LEN=:),INTENT(out),ALLOCATABLE :: out_string
+!-
   CHARACTER(LEN=1) :: first
-!---------------------------------------------------------------------
-  first="#"
-  eof = 0
-  out_string = "    "
-!-
-  DO WHILE (first == "#")
-    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
-    dummy = TRIM(ADJUSTL(dummy))
-    first=dummy(1:1)
-    IF (first == "#") THEN
-      nb_lastkey = 0
-    ENDIF
+  CHARACTER(LEN=:), ALLOCATABLE :: dummy
+!---------------------------------------------------------------------
+  first=COMMENT_TAG
+  is_eof = 0
+  dummy = ""
+!-
+! Loop until a non commented line is found
+  DO WHILE (first == COMMENT_TAG .AND. is_eof == 0)
+!-
+     CALL getin_readline(unit, dummy, is_eof)
+!-
+!    Is first char a comment? #
+     IF (LEN(dummy) > 0) THEN
+         first=dummy(1:1)
+         IF (first == COMMENT_TAG) THEN
+           nb_lastkey = 0
+         ENDIF
+     ENDIF
+!-
   ENDDO
-  out_string=dummy
+!-
+  CALL nocomment(dummy)
+  out_string = TRIM(dummy)
 !-
   RETURN
@@ -1517 +1590 @@
 !-
 7778 CONTINUE
-  eof = 1
+  CALL nocomment(dummy)
+  out_string = TRIM(dummy)
+  is_eof = 1
 !----------------------------
 END SUBROUTINE getin_skipafew

IOIPSL/trunk/src/histcom.f90

@@ -1699 +1699 @@
   CHARACTER(LEN=7) :: tmp_opp
   CHARACTER(LEN=13) :: c_nam
+  CHARACTER(LEN=20) :: tmpstr, tmpstr2
   LOGICAL :: l_dbg
+  INTEGER :: initzdim, varzdim
 !---------------------------------------------------------------------
   CALL ipsldbg (old_status=l_dbg)
@@ -1727 +1729 @@
 !-
   CALL histvar_seq (idf,pvarname,iv)
+!-
+! 1.2 Check for variable dimension is the same as declared
+!-
+  IF (PRESENT(pdata_2d) .OR. PRESENT(pdata_3d)) THEN
+      IF (PRESENT(pdata_2d)) varzdim = SIZE(pdata_2d, DIM=2)
+      IF (PRESENT(pdata_3d)) varzdim = SIZE(pdata_3d, DIM=2)
+
+      initzdim = W_F(idf)%W_V(iv)%zsize(3)
+      IF (initzdim .NE. varzdim) THEN
+        WRITE(tmpstr,  *) initzdim
+        WRITE(tmpstr2, *) varzdim
+        CALL ipslerr(3, "histwrite", "Variable="//pvarname,         &
+                        "Expected 3rd dimension size: "//TRIM(tmpstr),  &
+                        "But found: "//TRIM(tmpstr2))
+      ENDIF
+  ENDIF
 !-
 ! 2.0 do nothing for never operation

IOIPSL/trunk/src/restcom.f90

@@ -139 +139 @@
 ! A flag which markes the variables we have worked on :  touched_*
 !-
-  CHARACTER(LEN=20),DIMENSION(max_file,max_var),SAVE :: &
+  INTEGER, PARAMETER :: clen = 100
+  CHARACTER(LEN=clen),DIMENSION(max_file,max_var),SAVE :: &
  &  varname_in,varname_out
   INTEGER,DIMENSION(max_file,max_var),SAVE :: &
@@ -1090 +1091 @@
       'restart file is not allowed.',topp)
   ENDIF
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-----------------------------
 END SUBROUTINE restget_opp_r1d
@@ -1170 +1173 @@
       'restart file is not allowed.',topp)
   ENDIF
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-----------------------------
 END SUBROUTINE restget_opp_r2d
@@ -1258 +1263 @@
       'restart file is not allowed.',topp)
   ENDIF
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-----------------------------
 END SUBROUTINE restget_opp_r3d
@@ -1336 +1343 @@
       'restart file is not allowed.',topp)
   ENDIF
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-----------------------------
 END SUBROUTINE restget_opp_r4d
@@ -1416 +1425 @@
       'restart file is not allowed.',topp)
   ENDIF
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-----------------------------
 END SUBROUTINE restget_opp_r5d
@@ -1482 +1493 @@
     var(ji) = buff_tmp1(jl)
   ENDDO
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-------------------------
 END SUBROUTINE restget_r1d
@@ -1552 +1565 @@
     ENDDO
   ENDDO
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-------------------------
 END SUBROUTINE restget_r2d
@@ -1625 +1640 @@
     ENDDO
   ENDDO
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 !-------------------------
 END SUBROUTINE restget_r3d
@@ -1880 +1897 @@
  & (fid,vname_q,list_dims,itau,buff_tmp2)
 !-----------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_opp_r1d
 !===
@@ -1965 +1984 @@
   CALL restput_real (fid,vname_q, list_dims,itau,buff_tmp2)
 !-----------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_opp_r2d
 !===
@@ -2049 +2070 @@
  & (fid,vname_q,list_dims,itau,buff_tmp2)
 !-----------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_opp_r3d
 !===
@@ -2135 +2158 @@
  & (fid,vname_q,list_dims,itau,buff_tmp2)
 !-----------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_opp_r4d
 !===
@@ -2223 +2248 @@
  & (fid,vname_q,list_dims,itau,buff_tmp2)
 !-----------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_opp_r5d
 !===
@@ -2283 +2310 @@
   CALL restput_real (fid,vname_q,list_dims,itau,buff_tmp1)
 !-------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_r1d
 !===
@@ -2345 +2374 @@
   CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1)
 !-------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_r2d
 !===
@@ -2411 +2442 @@
   CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1)
 !-------------------------
+  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1)
+  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2)
 END SUBROUTINE restput_r3d
 !===
@@ -2596 +2629 @@
   CHARACTER(LEN=3) :: str
   LOGICAL :: l_dbg
+
+  CHARACTER(len=clen+10) :: str1, str2
 !---------------------------------------------------------------------
   CALL ipsldbg (old_status=l_dbg)
@@ -2625 +2660 @@
   ENDIF
   nbvar_out(fid) = nbvar_out(fid)+1
+  IF (len(trim(varname)) .GT. clen) THEN
+    write(str1,*) "Maximum length allowed: ", clen
+    write(str1,*) "But found: ", len(trim(varname))
+    CALL ipslerr (3,'restdefv', &
+      'Variable name too long for variable '//trim(varname), &
+        str1, str2)
+  ENDIF
+
   varname_out(fid,nbvar_out(fid)) = varname
 !-

IOIPSL/trunk/src/stringop.f90

@@ -6 +6 @@
 ! See IOIPSL/IOIPSL_License_CeCILL.txt
 !---------------------------------------------------------------------
+CHARACTER(LEN=1), PARAMETER :: COMMENT_TAG = "#" ! Comment symbol
+
 CONTAINS
 !=
@@ -120 +122 @@
 END SUBROUTINE nocomma
 !===
+SUBROUTINE nocomment (str)
+!---------------------------------------------------------------------
+!- Delete comment part from a line
+!
+!- line: TIME_SKIP=1D   # skip one day
+! to
+!  line: TIME_SKIP=1D
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*), INTENT(INOUT) :: str
+!-
+  INTEGER :: pos
+!---------------------------------------------------------------------
+  pos = INDEX(str, COMMENT_TAG)
+  IF (pos > 0) THEN
+    IF (pos == 1) THEN
+      str=""
+    ELSE
+      str=TRIM(str(1:pos-1))
+    ENDIF
+  ENDIF
+!---------------------
+END SUBROUTINE nocomment
+!===
 SUBROUTINE strlowercase (str)
 !---------------------------------------------------------------------