Changeset 4863 for IOIPSL/trunk/src/restcom.f90

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

File:

• IOIPSL/trunk/src/restcom.f90 (modified) (19 diffs)

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