Changeset 4863
- Timestamp:
- 12/16/19 14:33:26 (5 years ago)
- Location:
- IOIPSL/trunk/src
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/flincom.f90
r3474 r4863 691 691 INTEGER :: iv, lll 692 692 INTEGER :: xid, yid, zid, tid 693 CHARACTER(LEN= 80):: name693 CHARACTER(LEN=:), ALLOCATABLE :: name 694 694 CHARACTER(LEN=30) :: axname 695 695 !- … … 999 999 ENDDO 1000 1000 !------------------------- 1001 IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 1001 1002 END SUBROUTINE flinget_r1d 1002 1003 !- … … 1041 1042 ENDDO 1042 1043 !------------------------- 1044 IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 1043 1045 END SUBROUTINE flinget_r2d 1044 1046 !- … … 1083 1085 ENDDO 1084 1086 ENDDO 1087 IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 1085 1088 !-------------------------------- 1086 1089 END SUBROUTINE flinget_r2d_zoom2d … … 1128 1131 ENDDO 1129 1132 !------------------------- 1133 IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 1130 1134 END SUBROUTINE flinget_r3d 1131 1135 !- … … 1173 1177 ENDDO 1174 1178 !-------------------------------- 1179 IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 1175 1180 END SUBROUTINE flinget_r3d_zoom2d 1176 1181 !- … … 1219 1224 ENDDO 1220 1225 !------------------------- 1226 IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 1221 1227 END SUBROUTINE flinget_r4d 1222 1228 !- … … 1266 1272 ENDDO 1267 1273 !-------------------------------- 1274 IF (ALLOCATED(buff_tmp)) DEALLOCATE(buff_tmp) 1268 1275 END SUBROUTINE flinget_r4d_zoom2d 1269 1276 !- -
IOIPSL/trunk/src/getincom.f90
r3279 r4863 8 8 USE errioipsl, ONLY : ipslerr,ipsldbg,ipslout 9 9 USE stringop, & 10 & ONLY : nocomma,cmpblank,strlowercase 10 & ONLY : nocomma,cmpblank,strlowercase,nocomment, COMMENT_TAG 11 11 !- 12 12 IMPLICIT NONE … … 436 436 CHARACTER(LEN=*) :: ret_val 437 437 !- 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' ,'') 441 447 !- 442 448 ! Do we have this targetname in our database ? … … 458 464 ENDIF 459 465 ret_val = tmp_ret_val(1) 466 !-- 467 DEALLOCATE(tmp_ret_val) 460 468 !--------------------- 461 469 END SUBROUTINE getincs … … 717 725 INTEGER :: k_typ,it,pos,len_str,status_cnt,io_err 718 726 CHARACTER(LEN=n_d_fmt) :: cnt 719 CHARACTER(LEN= 80):: str_READ,str_READ_lower727 CHARACTER(LEN=:), ALLOCATABLE :: str_READ,str_READ_lower 720 728 CHARACTER(LEN=9) :: c_vtyp 721 729 LOGICAL,DIMENSION(:),ALLOCATABLE :: found … … 1123 1131 INTEGER :: current 1124 1132 !- 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 1126 1135 CHARACTER(LEN=n_d_fmt) :: cnt 1127 1136 CHARACTER(LEN=10) :: c_fmt … … 1262 1271 !- 1263 1272 INTEGER :: len_str,blk,nbve,starpos 1264 CHARACTER(LEN= 300):: tmp_str,new_key,mult1273 CHARACTER(LEN=:), ALLOCATABLE :: tmp_str,new_key,mult 1265 1274 CHARACTER(LEN=n_d_fmt) :: cnt 1266 1275 CHARACTER(LEN=10) :: c_fmt … … 1488 1497 !=== 1489 1498 !- 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 1499 SUBROUTINE 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 !- 1541 9998 CONTINUE 1542 CALL ipslerr (3,'getin_readline','Error while reading file',' ',' ') 1543 !- 1544 7778 CONTINUE 1545 out_string = TRIM(dummy) 1546 is_eof = 1 1547 1548 END SUBROUTINE getin_readline 1549 !- 1550 ! getin_skipafew: reads 1551 !- 1552 SUBROUTINE 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 !- 1497 1561 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 !- 1510 1581 ENDDO 1511 out_string=dummy 1582 !- 1583 CALL nocomment(dummy) 1584 out_string = TRIM(dummy) 1512 1585 !- 1513 1586 RETURN … … 1517 1590 !- 1518 1591 7778 CONTINUE 1519 eof = 1 1592 CALL nocomment(dummy) 1593 out_string = TRIM(dummy) 1594 is_eof = 1 1520 1595 !---------------------------- 1521 1596 END SUBROUTINE getin_skipafew -
IOIPSL/trunk/src/histcom.f90
r4419 r4863 1699 1699 CHARACTER(LEN=7) :: tmp_opp 1700 1700 CHARACTER(LEN=13) :: c_nam 1701 CHARACTER(LEN=20) :: tmpstr, tmpstr2 1701 1702 LOGICAL :: l_dbg 1703 INTEGER :: initzdim, varzdim 1702 1704 !--------------------------------------------------------------------- 1703 1705 CALL ipsldbg (old_status=l_dbg) … … 1727 1729 !- 1728 1730 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 1729 1747 !- 1730 1748 ! 2.0 do nothing for never operation -
IOIPSL/trunk/src/restcom.f90
r4747 r4863 139 139 ! A flag which markes the variables we have worked on : touched_* 140 140 !- 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 :: & 142 143 & varname_in,varname_out 143 144 INTEGER,DIMENSION(max_file,max_var),SAVE :: & … … 1090 1091 'restart file is not allowed.',topp) 1091 1092 ENDIF 1093 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1094 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1092 1095 !----------------------------- 1093 1096 END SUBROUTINE restget_opp_r1d … … 1170 1173 'restart file is not allowed.',topp) 1171 1174 ENDIF 1175 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1176 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1172 1177 !----------------------------- 1173 1178 END SUBROUTINE restget_opp_r2d … … 1258 1263 'restart file is not allowed.',topp) 1259 1264 ENDIF 1265 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1266 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1260 1267 !----------------------------- 1261 1268 END SUBROUTINE restget_opp_r3d … … 1336 1343 'restart file is not allowed.',topp) 1337 1344 ENDIF 1345 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1346 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1338 1347 !----------------------------- 1339 1348 END SUBROUTINE restget_opp_r4d … … 1416 1425 'restart file is not allowed.',topp) 1417 1426 ENDIF 1427 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1428 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1418 1429 !----------------------------- 1419 1430 END SUBROUTINE restget_opp_r5d … … 1482 1493 var(ji) = buff_tmp1(jl) 1483 1494 ENDDO 1495 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1496 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1484 1497 !------------------------- 1485 1498 END SUBROUTINE restget_r1d … … 1552 1565 ENDDO 1553 1566 ENDDO 1567 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1568 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1554 1569 !------------------------- 1555 1570 END SUBROUTINE restget_r2d … … 1625 1640 ENDDO 1626 1641 ENDDO 1642 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1643 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1627 1644 !------------------------- 1628 1645 END SUBROUTINE restget_r3d … … 1880 1897 & (fid,vname_q,list_dims,itau,buff_tmp2) 1881 1898 !----------------------------- 1899 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1900 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1882 1901 END SUBROUTINE restput_opp_r1d 1883 1902 !=== … … 1965 1984 CALL restput_real (fid,vname_q, list_dims,itau,buff_tmp2) 1966 1985 !----------------------------- 1986 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 1987 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 1967 1988 END SUBROUTINE restput_opp_r2d 1968 1989 !=== … … 2049 2070 & (fid,vname_q,list_dims,itau,buff_tmp2) 2050 2071 !----------------------------- 2072 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 2073 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 2051 2074 END SUBROUTINE restput_opp_r3d 2052 2075 !=== … … 2135 2158 & (fid,vname_q,list_dims,itau,buff_tmp2) 2136 2159 !----------------------------- 2160 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 2161 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 2137 2162 END SUBROUTINE restput_opp_r4d 2138 2163 !=== … … 2223 2248 & (fid,vname_q,list_dims,itau,buff_tmp2) 2224 2249 !----------------------------- 2250 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 2251 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 2225 2252 END SUBROUTINE restput_opp_r5d 2226 2253 !=== … … 2283 2310 CALL restput_real (fid,vname_q,list_dims,itau,buff_tmp1) 2284 2311 !------------------------- 2312 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 2313 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 2285 2314 END SUBROUTINE restput_r1d 2286 2315 !=== … … 2345 2374 CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1) 2346 2375 !------------------------- 2376 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 2377 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 2347 2378 END SUBROUTINE restput_r2d 2348 2379 !=== … … 2411 2442 CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1) 2412 2443 !------------------------- 2444 IF (ALLOCATED(buff_tmp1)) DEALLOCATE(buff_tmp1) 2445 IF (ALLOCATED(buff_tmp2)) DEALLOCATE(buff_tmp2) 2413 2446 END SUBROUTINE restput_r3d 2414 2447 !=== … … 2596 2629 CHARACTER(LEN=3) :: str 2597 2630 LOGICAL :: l_dbg 2631 2632 CHARACTER(len=clen+10) :: str1, str2 2598 2633 !--------------------------------------------------------------------- 2599 2634 CALL ipsldbg (old_status=l_dbg) … … 2625 2660 ENDIF 2626 2661 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 2627 2670 varname_out(fid,nbvar_out(fid)) = varname 2628 2671 !- -
IOIPSL/trunk/src/stringop.f90
r936 r4863 6 6 ! See IOIPSL/IOIPSL_License_CeCILL.txt 7 7 !--------------------------------------------------------------------- 8 CHARACTER(LEN=1), PARAMETER :: COMMENT_TAG = "#" ! Comment symbol 9 8 10 CONTAINS 9 11 != … … 120 122 END SUBROUTINE nocomma 121 123 !=== 124 SUBROUTINE 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 !--------------------- 147 END SUBROUTINE nocomment 148 !=== 122 149 SUBROUTINE strlowercase (str) 123 150 !---------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.