Changeset 4863


Ignore:
Timestamp:
12/16/19 14:33:26 (15 months 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:
5 edited

Legend:

Unmodified
Added
Removed
  • IOIPSL/trunk/src/flincom.f90

    r3474 r4863  
    691691  INTEGER :: iv, lll 
    692692  INTEGER :: xid, yid, zid, tid 
    693   CHARACTER(LEN=80) :: name 
     693  CHARACTER(LEN=:), ALLOCATABLE :: name 
    694694  CHARACTER(LEN=30) :: axname 
    695695!- 
     
    999999  ENDDO 
    10001000!------------------------- 
     1001  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 
    10011002END SUBROUTINE flinget_r1d 
    10021003!- 
     
    10411042  ENDDO 
    10421043!------------------------- 
     1044  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 
    10431045END SUBROUTINE flinget_r2d 
    10441046!- 
     
    10831085    ENDDO 
    10841086  ENDDO 
     1087  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 
    10851088!-------------------------------- 
    10861089END SUBROUTINE flinget_r2d_zoom2d 
     
    11281131  ENDDO 
    11291132!------------------------- 
     1133  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 
    11301134END SUBROUTINE flinget_r3d 
    11311135!- 
     
    11731177  ENDDO 
    11741178!-------------------------------- 
     1179  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 
    11751180END SUBROUTINE flinget_r3d_zoom2d 
    11761181!- 
     
    12191224  ENDDO 
    12201225!------------------------- 
     1226  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 
    12211227END SUBROUTINE flinget_r4d 
    12221228!- 
     
    12661272  ENDDO 
    12671273!-------------------------------- 
     1274  IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 
    12681275END SUBROUTINE flinget_r4d_zoom2d 
    12691276!- 
  • IOIPSL/trunk/src/getincom.f90

    r3279 r4863  
    88USE errioipsl, ONLY : ipslerr,ipsldbg,ipslout 
    99USE stringop, & 
    10  &   ONLY : nocomma,cmpblank,strlowercase 
     10 &   ONLY : nocomma,cmpblank,strlowercase,nocomment, COMMENT_TAG 
    1111!- 
    1212IMPLICIT NONE 
     
    436436  CHARACTER(LEN=*) :: ret_val 
    437437!- 
    438   CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val 
    439   INTEGER :: pos,status=0,fileorig,size_of_in 
    440 !--------------------------------------------------------------------- 
     438  CHARACTER(LEN=:),ALLOCATABLE,DIMENSION(:) :: tmp_ret_val 
     439  INTEGER :: pos,status=0,fileorig,size_of_in,ier 
     440  INTEGER :: inlength 
     441!--------------------------------------------------------------------- 
     442!- 
     443  inlength = LEN(ret_val) 
     444  ALLOCATE(CHARACTER(inlength) :: tmp_ret_val(1), stat=ier) 
     445  IF (ier /= 0) CALL ipslerr(3, 'getincs', 'Allocation memory problem for', & 
     446                             'tmp_ret_val' ,'') 
    441447!- 
    442448! Do we have this targetname in our database ? 
     
    458464  ENDIF 
    459465  ret_val = tmp_ret_val(1) 
     466!-- 
     467  DEALLOCATE(tmp_ret_val) 
    460468!--------------------- 
    461469END SUBROUTINE getincs 
     
    717725  INTEGER :: k_typ,it,pos,len_str,status_cnt,io_err 
    718726  CHARACTER(LEN=n_d_fmt)  :: cnt 
    719   CHARACTER(LEN=80) :: str_READ,str_READ_lower 
     727  CHARACTER(LEN=:), ALLOCATABLE :: str_READ,str_READ_lower 
    720728  CHARACTER(LEN=9)  :: c_vtyp 
    721729  LOGICAL,DIMENSION(:),ALLOCATABLE :: found 
     
    11231131  INTEGER :: current 
    11241132!- 
    1125   CHARACTER(LEN=300) :: READ_str,NEW_str,last_key,key_str 
     1133  CHARACTER(LEN=:), ALLOCATABLE :: READ_str, NEW_str 
     1134  CHARACTER(LEN=300) :: last_key,key_str 
    11261135  CHARACTER(LEN=n_d_fmt) :: cnt 
    11271136  CHARACTER(LEN=10) :: c_fmt 
     
    12621271!- 
    12631272  INTEGER :: len_str,blk,nbve,starpos 
    1264   CHARACTER(LEN=300) :: tmp_str,new_key,mult 
     1273  CHARACTER(LEN=:), ALLOCATABLE :: tmp_str,new_key,mult 
    12651274  CHARACTER(LEN=n_d_fmt) :: cnt 
    12661275  CHARACTER(LEN=10) :: c_fmt 
     
    14881497!=== 
    14891498!- 
    1490 SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey) 
    1491 !--------------------------------------------------------------------- 
    1492   IMPLICIT NONE 
    1493 !- 
    1494   INTEGER :: unit,eof,nb_lastkey 
    1495   CHARACTER(LEN=300) :: dummy 
    1496   CHARACTER(LEN=300),INTENT(out) :: out_string 
     1499SUBROUTINE getin_readline(unitf, out_string, is_eof) 
     1500!--------------------------------------------------------------------- 
     1501  USE ISO_FORTRAN_ENV,ONLY : IOSTAT_EOR,IOSTAT_END 
     1502!- 
     1503  IMPLICIT NONE 
     1504!- 
     1505  INTEGER, PARAMETER :: CHARLEN = 100     ! buffer size 
     1506  INTEGER, INTENT(in) :: unitf 
     1507  INTEGER, INTENT(out) :: is_eof 
     1508  CHARACTER(LEN=:),INTENT(out),ALLOCATABLE :: out_string 
     1509!- 
     1510  CHARACTER(LEN=CHARLEN)  :: dummy 
     1511!- 
     1512  CHARACTER(LEN=:), ALLOCATABLE :: buff1  ! buffer 
     1513  INTEGER :: ioerr                  ! error code 
     1514  INTEGER :: readlength                   ! number of chars read from file  
     1515  LOGICAL :: is_eol, is_first_ite         ! end of line?  
     1516 
     1517  is_eof = 0 
     1518  is_eol = .FALSE. 
     1519  buff1 = "" 
     1520 
     1521  DO WHILE (.NOT. is_eol) 
     1522!- 
     1523      dummy = "" 
     1524      READ (UNIT=unitf,FMT='(A)', ADVANCE='NO', SIZE=readlength,ERR=9998,END=7778,IOSTAT=ioerr) dummy 
     1525      IF ((ioerr==IOSTAT_EOR).OR.(ioerr==IOSTAT_END)) ioerr = 0 
     1526!- 
     1527      ! keep looping if line is commented 
     1528      dummy = TRIM(ADJUSTL(dummy)) 
     1529!- 
     1530      ! is end of line? 
     1531      is_eol = (readlength .LT. CHARLEN) 
     1532!- 
     1533      ! merge with previous buffer 
     1534      buff1 = TRIM(buff1)//TRIM(dummy) 
     1535  ENDDO 
     1536!- 
     1537  out_string=TRIM(buff1) 
     1538!- 
     1539  RETURN 
     1540!- 
     15419998 CONTINUE 
     1542  CALL ipslerr (3,'getin_readline','Error while reading file',' ',' ') 
     1543!- 
     15447778 CONTINUE 
     1545  out_string = TRIM(dummy) 
     1546  is_eof = 1 
     1547     
     1548END SUBROUTINE getin_readline 
     1549!- 
     1550! getin_skipafew: reads   
     1551!- 
     1552SUBROUTINE getin_skipafew (unit,out_string,is_eof,nb_lastkey) 
     1553!--------------------------------------------------------------------- 
     1554  USE ISO_FORTRAN_ENV,ONLY : IOSTAT_EOR,IOSTAT_END 
     1555!- 
     1556  IMPLICIT NONE 
     1557!- 
     1558  INTEGER :: unit,is_eof,nb_lastkey 
     1559  CHARACTER(LEN=:),INTENT(out),ALLOCATABLE :: out_string 
     1560!- 
    14971561  CHARACTER(LEN=1) :: first 
    1498 !--------------------------------------------------------------------- 
    1499   first="#" 
    1500   eof = 0 
    1501   out_string = "    " 
    1502 !- 
    1503   DO WHILE (first == "#") 
    1504     READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy 
    1505     dummy = TRIM(ADJUSTL(dummy)) 
    1506     first=dummy(1:1) 
    1507     IF (first == "#") THEN 
    1508       nb_lastkey = 0 
    1509     ENDIF 
     1562  CHARACTER(LEN=:), ALLOCATABLE :: dummy 
     1563!--------------------------------------------------------------------- 
     1564  first=COMMENT_TAG 
     1565  is_eof = 0 
     1566  dummy = "" 
     1567!- 
     1568! Loop until a non commented line is found 
     1569  DO WHILE (first == COMMENT_TAG .AND. is_eof == 0) 
     1570!- 
     1571     CALL getin_readline(unit, dummy, is_eof) 
     1572!- 
     1573!    Is first char a comment? # 
     1574     IF (LEN(dummy) > 0) THEN 
     1575         first=dummy(1:1) 
     1576         IF (first == COMMENT_TAG) THEN 
     1577           nb_lastkey = 0 
     1578         ENDIF 
     1579     ENDIF 
     1580!- 
    15101581  ENDDO 
    1511   out_string=dummy 
     1582!- 
     1583  CALL nocomment(dummy) 
     1584  out_string = TRIM(dummy) 
    15121585!- 
    15131586  RETURN 
     
    15171590!- 
    151815917778 CONTINUE 
    1519   eof = 1 
     1592  CALL nocomment(dummy) 
     1593  out_string = TRIM(dummy) 
     1594  is_eof = 1 
    15201595!---------------------------- 
    15211596END SUBROUTINE getin_skipafew 
  • IOIPSL/trunk/src/histcom.f90

    r4419 r4863  
    16991699  CHARACTER(LEN=7) :: tmp_opp 
    17001700  CHARACTER(LEN=13) :: c_nam 
     1701  CHARACTER(LEN=20) :: tmpstr, tmpstr2 
    17011702  LOGICAL :: l_dbg 
     1703  INTEGER :: initzdim, varzdim 
    17021704!--------------------------------------------------------------------- 
    17031705  CALL ipsldbg (old_status=l_dbg) 
     
    17271729!- 
    17281730  CALL histvar_seq (idf,pvarname,iv) 
     1731!- 
     1732! 1.2 Check for variable dimension is the same as declared 
     1733!- 
     1734  IF (PRESENT(pdata_2d) .OR. PRESENT(pdata_3d)) THEN 
     1735      IF (PRESENT(pdata_2d)) varzdim = SIZE(pdata_2d, DIM=2) 
     1736      IF (PRESENT(pdata_3d)) varzdim = SIZE(pdata_3d, DIM=2) 
     1737 
     1738      initzdim = W_F(idf)%W_V(iv)%zsize(3) 
     1739      IF (initzdim .NE. varzdim) THEN 
     1740        WRITE(tmpstr,  *) initzdim 
     1741        WRITE(tmpstr2, *) varzdim 
     1742        CALL ipslerr(3, "histwrite", "Variable="//pvarname,         & 
     1743                        "Expected 3rd dimension size: "//TRIM(tmpstr),  & 
     1744                        "But found: "//TRIM(tmpstr2)) 
     1745      ENDIF 
     1746  ENDIF 
    17291747!- 
    17301748! 2.0 do nothing for never operation 
  • IOIPSL/trunk/src/restcom.f90

    r4747 r4863  
    139139! A flag which markes the variables we have worked on :  touched_* 
    140140!- 
    141   CHARACTER(LEN=20),DIMENSION(max_file,max_var),SAVE :: & 
     141  INTEGER, PARAMETER :: clen = 100 
     142  CHARACTER(LEN=clen),DIMENSION(max_file,max_var),SAVE :: & 
    142143 &  varname_in,varname_out 
    143144  INTEGER,DIMENSION(max_file,max_var),SAVE :: & 
     
    10901091      'restart file is not allowed.',topp) 
    10911092  ENDIF 
     1093  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1094  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    10921095!----------------------------- 
    10931096END SUBROUTINE restget_opp_r1d 
     
    11701173      'restart file is not allowed.',topp) 
    11711174  ENDIF 
     1175  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1176  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    11721177!----------------------------- 
    11731178END SUBROUTINE restget_opp_r2d 
     
    12581263      'restart file is not allowed.',topp) 
    12591264  ENDIF 
     1265  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1266  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    12601267!----------------------------- 
    12611268END SUBROUTINE restget_opp_r3d 
     
    13361343      'restart file is not allowed.',topp) 
    13371344  ENDIF 
     1345  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1346  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    13381347!----------------------------- 
    13391348END SUBROUTINE restget_opp_r4d 
     
    14161425      'restart file is not allowed.',topp) 
    14171426  ENDIF 
     1427  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1428  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    14181429!----------------------------- 
    14191430END SUBROUTINE restget_opp_r5d 
     
    14821493    var(ji) = buff_tmp1(jl) 
    14831494  ENDDO 
     1495  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1496  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    14841497!------------------------- 
    14851498END SUBROUTINE restget_r1d 
     
    15521565    ENDDO 
    15531566  ENDDO 
     1567  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1568  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    15541569!------------------------- 
    15551570END SUBROUTINE restget_r2d 
     
    16251640    ENDDO 
    16261641  ENDDO 
     1642  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1643  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    16271644!------------------------- 
    16281645END SUBROUTINE restget_r3d 
     
    18801897 & (fid,vname_q,list_dims,itau,buff_tmp2) 
    18811898!----------------------------- 
     1899  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1900  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    18821901END SUBROUTINE restput_opp_r1d 
    18831902!=== 
     
    19651984  CALL restput_real (fid,vname_q, list_dims,itau,buff_tmp2) 
    19661985!----------------------------- 
     1986  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     1987  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    19671988END SUBROUTINE restput_opp_r2d 
    19681989!=== 
     
    20492070 & (fid,vname_q,list_dims,itau,buff_tmp2) 
    20502071!----------------------------- 
     2072  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     2073  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    20512074END SUBROUTINE restput_opp_r3d 
    20522075!=== 
     
    21352158 & (fid,vname_q,list_dims,itau,buff_tmp2) 
    21362159!----------------------------- 
     2160  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     2161  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    21372162END SUBROUTINE restput_opp_r4d 
    21382163!=== 
     
    22232248 & (fid,vname_q,list_dims,itau,buff_tmp2) 
    22242249!----------------------------- 
     2250  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     2251  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    22252252END SUBROUTINE restput_opp_r5d 
    22262253!=== 
     
    22832310  CALL restput_real (fid,vname_q,list_dims,itau,buff_tmp1) 
    22842311!------------------------- 
     2312  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     2313  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    22852314END SUBROUTINE restput_r1d 
    22862315!=== 
     
    23452374  CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1) 
    23462375!------------------------- 
     2376  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     2377  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    23472378END SUBROUTINE restput_r2d 
    23482379!=== 
     
    24112442  CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1) 
    24122443!------------------------- 
     2444  IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 
     2445  IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 
    24132446END SUBROUTINE restput_r3d 
    24142447!=== 
     
    25962629  CHARACTER(LEN=3) :: str 
    25972630  LOGICAL :: l_dbg 
     2631 
     2632  CHARACTER(len=clen+10) :: str1, str2 
    25982633!--------------------------------------------------------------------- 
    25992634  CALL ipsldbg (old_status=l_dbg) 
     
    26252660  ENDIF 
    26262661  nbvar_out(fid) = nbvar_out(fid)+1 
     2662  IF (len(trim(varname)) .GT. clen) THEN 
     2663    write(str1,*) "Maximum length allowed: ", clen 
     2664    write(str1,*) "But found: ", len(trim(varname)) 
     2665    CALL ipslerr (3,'restdefv', & 
     2666      'Variable name too long for variable '//trim(varname), & 
     2667        str1, str2) 
     2668  ENDIF 
     2669 
    26272670  varname_out(fid,nbvar_out(fid)) = varname 
    26282671!- 
  • IOIPSL/trunk/src/stringop.f90

    r936 r4863  
    66! See IOIPSL/IOIPSL_License_CeCILL.txt 
    77!--------------------------------------------------------------------- 
     8CHARACTER(LEN=1), PARAMETER :: COMMENT_TAG = "#" ! Comment symbol 
     9 
    810CONTAINS 
    911!= 
     
    120122END SUBROUTINE nocomma 
    121123!=== 
     124SUBROUTINE nocomment (str) 
     125!--------------------------------------------------------------------- 
     126!- Delete comment part from a line 
     127! 
     128!- line: TIME_SKIP=1D   # skip one day 
     129! to 
     130!  line: TIME_SKIP=1D 
     131!--------------------------------------------------------------------- 
     132  IMPLICIT NONE 
     133!- 
     134  CHARACTER(LEN=*), INTENT(INOUT) :: str 
     135!- 
     136  INTEGER :: pos 
     137!--------------------------------------------------------------------- 
     138  pos = INDEX(str, COMMENT_TAG) 
     139  IF (pos > 0) THEN 
     140    IF (pos == 1) THEN 
     141      str="" 
     142    ELSE 
     143      str=TRIM(str(1:pos-1)) 
     144    ENDIF 
     145  ENDIF 
     146!--------------------- 
     147END SUBROUTINE nocomment 
     148!=== 
    122149SUBROUTINE strlowercase (str) 
    123150!--------------------------------------------------------------------- 
Note: See TracChangeset for help on using the changeset viewer.