Changeset 4863 for IOIPSL/trunk/src/getincom.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/getincom.f90 (modified) (8 diffs)

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