Changeset 845
- Timestamp:
- 12/10/09 17:26:03 (15 years ago)
- Location:
- IOIPSL/trunk/src
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/histcom.f90
r806 r845 88 88 CHARACTER(LEN=80) :: title,std_name,fullop 89 89 CHARACTER(LEN=7) :: topp 90 CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp s90 CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp 91 91 REAL,DIMENSION(nbopp_max) :: scal 92 92 !-External type (for R4/R8) … … 1158 1158 CHARACTER(LEN=40) :: str40 1159 1159 CHARACTER(LEN=10) :: str10 1160 CHARACTER(LEN=80) :: tmp_str801161 CHARACTER(LEN=7) :: tmp_topp,tmp_sopp(nbopp_max)1162 1160 CHARACTER(LEN=120) :: ex_topps 1163 REAL :: tmp_scal(nbopp_max),un_an,un_jour,test_fopp,test_fwrt1161 REAL :: un_an,un_jour,test_fopp,test_fwrt 1164 1162 INTEGER :: pos,buff_sz 1165 1163 LOGICAL :: l_dbg … … 1211 1209 !- 1212 1210 W_F(pfileid)%W_V(iv)%fullop = popp 1213 tmp_str80 = popp1214 1211 CALL buildop & 1215 & (tmp_str80,ex_topps,tmp_topp,nbopp_max,missing_val, & 1216 & tmp_sopp,tmp_scal,W_F(pfileid)%W_V(iv)%nbopp) 1217 !- 1218 W_F(pfileid)%W_V(iv)%topp = tmp_topp 1219 DO i=1,W_F(pfileid)%W_V(iv)%nbopp 1220 W_F(pfileid)%W_V(iv)%sopps(i) = tmp_sopp(i) 1221 W_F(pfileid)%W_V(iv)%scal(i) = tmp_scal(i) 1222 ENDDO 1212 & (TRIM(popp),ex_topps,W_F(pfileid)%W_V(iv)%topp,missing_val, & 1213 & W_F(pfileid)%W_V(iv)%sopp,W_F(pfileid)%W_V(iv)%scal, & 1214 & W_F(pfileid)%W_V(iv)%nbopp) 1223 1215 !- 1224 1216 ! 1.2 If we have an even number of operations 1225 1217 ! then we need to add identity 1226 1218 !- 1227 IF ( 2*INT(W_F(pfileid)%W_V(iv)%nbopp/2.0) & 1228 & == W_F(pfileid)%W_V(iv)%nbopp) THEN 1219 IF ( MOD(W_F(pfileid)%W_V(iv)%nbopp,2) == 0) THEN 1229 1220 W_F(pfileid)%W_V(iv)%nbopp = W_F(pfileid)%W_V(iv)%nbopp+1 1230 W_F(pfileid)%W_V(iv)%sopp s(W_F(pfileid)%W_V(iv)%nbopp) = 'ident'1221 W_F(pfileid)%W_V(iv)%sopp(W_F(pfileid)%W_V(iv)%nbopp) = 'ident' 1231 1222 W_F(pfileid)%W_V(iv)%scal(W_F(pfileid)%W_V(iv)%nbopp) = missing_val 1232 1223 ENDIF … … 1244 1235 IF (l_dbg) THEN 1245 1236 WRITE(*,*) "histdef : 2.0",pfileid,iv,W_F(pfileid)%W_V(iv)%nbopp, & 1246 & W_F(pfileid)%W_V(iv)%sopp s(1:W_F(pfileid)%W_V(iv)%nbopp), &1237 & W_F(pfileid)%W_V(iv)%sopp(1:W_F(pfileid)%W_V(iv)%nbopp), & 1247 1238 & W_F(pfileid)%W_V(iv)%scal(1:W_F(pfileid)%W_V(iv)%nbopp) 1248 1239 ENDIF … … 1348 1339 ! which need bufferisation 1349 1340 !- 1350 IF ( (TRIM( tmp_topp) /= "inst") &1351 & .AND.(TRIM( tmp_topp) /= "once") &1352 & .AND.(TRIM( tmp_topp) /= "never") )THEN1341 IF ( (TRIM(W_F(pfileid)%W_V(iv)%topp) /= "inst") & 1342 & .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= "once") & 1343 & .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= "never") )THEN 1353 1344 W_F(pfileid)%W_V(iv)%point = buff_pos+1 1354 1345 buff_pos = buff_pos+buff_sz … … 1410 1401 ! its compaticility with the choice of frequencies 1411 1402 !- 1412 IF (TRIM( tmp_topp) == "inst") THEN1403 IF (TRIM(W_F(pfileid)%W_V(iv)%topp) == "inst") THEN 1413 1404 IF (test_fopp /= test_fwrt) THEN 1414 1405 str70 = 'For instantaneous output the frequency '// & … … 1427 1418 ENDIF 1428 1419 ENDIF 1429 ELSE IF (INDEX(ex_topps,TRIM( tmp_topp)) > 0) THEN1420 ELSE IF (INDEX(ex_topps,TRIM(W_F(pfileid)%W_V(iv)%topp)) > 0) THEN 1430 1421 IF (test_fopp > test_fwrt) THEN 1431 1422 str70 = 'For averages the frequency of operations '// & 1432 &'should be smaller or equal'1423 & 'should be smaller or equal' 1433 1424 WRITE(str71, & 1434 1425 & '("to that of output. It is not the case for variable ",a)') & … … 1439 1430 ENDIF 1440 1431 ELSE 1441 WRITE (str70,'("Operation on variable ",a," is unknown")') & 1442 & TRIM(tmp_name) 1443 WRITE (str71,'("operation requested is :",a)') tmp_topp 1432 WRITE (str70,'("Operation on variable ",A," is unknown")') & 1433 & TRIM(tmp_name) 1434 WRITE (str71,'("operation requested is :",A)') & 1435 & W_F(pfileid)%W_V(iv)%topp 1444 1436 WRITE (str72,'("File ID :",I3)') pfileid 1445 1437 CALL ipslerr (3,"histdef",str70,str71,str72) … … 1478 1470 IF (W_F(pfileid)%W_V(iv)%freq_wrt > 0) THEN 1479 1471 WRITE(str10,'(I8.8)') INT(W_F(pfileid)%W_V(iv)%freq_wrt) 1480 str40 = TRIM( tmp_topp)//"_"//TRIM(str10)1472 str40 = TRIM(W_F(pfileid)%W_V(iv)%topp)//"_"//TRIM(str10) 1481 1473 ELSE 1482 1474 WRITE(str10,'(I2.2,"month")') ABS(INT(W_F(pfileid)%W_V(iv)%freq_wrt)) 1483 str40 = TRIM( tmp_topp)//"_"//TRIM(str10)1475 str40 = TRIM(W_F(pfileid)%W_V(iv)%topp)//"_"//TRIM(str10) 1484 1476 ENDIF 1485 1477 CALL find_str (W_F(pfileid)%W_V(1:W_F(pfileid)%n_tax)%tax_name,str40,pos) … … 1487 1479 ! No time axis for once, l_max, l_min or never operation 1488 1480 !- 1489 IF ( (TRIM( tmp_topp) /= 'once') &1490 & .AND.(TRIM( tmp_topp) /= 'never') &1491 & .AND.(TRIM( tmp_topp) /= 'l_max') &1492 & .AND.(TRIM( tmp_topp) /= 'l_min') ) THEN1481 IF ( (TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'once') & 1482 & .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'never') & 1483 & .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'l_max') & 1484 & .AND.(TRIM(W_F(pfileid)%W_V(iv)%topp) /= 'l_min') ) THEN 1493 1485 IF (pos < 0) THEN 1494 1486 W_F(pfileid)%n_tax = W_F(pfileid)%n_tax+1 … … 1500 1492 ENDIF 1501 1493 ELSE 1502 IF (l_dbg) WRITE(*,*) "histdef : 7.0 ",TRIM(tmp_topp),'----' 1494 IF (l_dbg) THEN 1495 WRITE(*,*) "histdef : 7.0 ",TRIM(W_F(pfileid)%W_V(iv)%topp),'----' 1496 ENDIF 1503 1497 W_F(pfileid)%W_V(iv)%t_axid = -99 1504 1498 ENDIF … … 1507 1501 ! for never or once operation 1508 1502 !- 1509 IF ( (TRIM( tmp_topp) == 'once') &1510 & .OR.(TRIM( tmp_topp) == 'never') ) THEN1503 IF ( (TRIM(W_F(pfileid)%W_V(iv)%topp) == 'once') & 1504 & .OR.(TRIM(W_F(pfileid)%W_V(iv)%topp) == 'never') ) THEN 1511 1505 W_F(pfileid)%W_V(iv)%freq_opp = 0. 1512 1506 W_F(pfileid)%W_V(iv)%freq_wrt = 0. … … 1896 1890 largebuf = .FALSE. 1897 1891 DO io=1,W_F(pfileid)%W_V(varid)%nbopp 1898 IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopp s(io)) > 0) THEN1892 IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopp(io)) > 0) THEN 1899 1893 largebuf = .TRUE. 1900 1894 ENDIF … … 1948 1942 IF (l1d) THEN 1949 1943 nbpt_in1 = W_F(pfileid)%W_V(varid)%datasz_in(1) 1950 CALL mathop (W_F(pfileid)%W_V(varid)%sopp s(1),nbpt_in1,pdata_1d, &1944 CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in1,pdata_1d, & 1951 1945 & missing_val,nbindex,nindex, & 1952 1946 & W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 1953 1947 ELSE IF (l2d) THEN 1954 1948 nbpt_in2(1:2) = W_F(pfileid)%W_V(varid)%datasz_in(1:2) 1955 CALL mathop (W_F(pfileid)%W_V(varid)%sopp s(1),nbpt_in2,pdata_2d, &1949 CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in2,pdata_2d, & 1956 1950 & missing_val,nbindex,nindex, & 1957 1951 & W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 1958 1952 ELSE IF (l3d) THEN 1959 1953 nbpt_in3(1:3) = W_F(pfileid)%W_V(varid)%datasz_in(1:3) 1960 CALL mathop (W_F(pfileid)%W_V(varid)%sopp s(1),nbpt_in3,pdata_3d, &1954 CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in3,pdata_3d, & 1961 1955 & missing_val,nbindex,nindex, & 1962 1956 & W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) … … 2090 2084 nbin = nbout 2091 2085 nbout = W_F(i)%W_V(varid)%datasz_max 2092 CALL mathop(W_F(i)%W_V(varid)%sopp s(io),nbin,buff_tmp, &2086 CALL mathop(W_F(i)%W_V(varid)%sopp(io),nbin,buff_tmp, & 2093 2087 & missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io), & 2094 2088 & nbout,buff_tmp2) 2095 2089 IF (l_dbg) THEN 2096 2090 WRITE(*,*) & 2097 & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp s(io)2091 & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp(io) 2098 2092 ENDIF 2099 2093 !- 2100 2094 nbin = nbout 2101 2095 nbout = W_F(i)%W_V(varid)%datasz_max 2102 CALL mathop(W_F(i)%W_V(varid)%sopp s(io+1),nbin,buff_tmp2, &2096 CALL mathop(W_F(i)%W_V(varid)%sopp(io+1),nbin,buff_tmp2, & 2103 2097 & missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io+1), & 2104 2098 & nbout,buff_tmp) 2105 2099 IF (l_dbg) THEN 2106 2100 WRITE(*,*) & 2107 & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp s(io+1)2101 & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp(io+1) 2108 2102 ENDIF 2109 2103 ENDDO -
IOIPSL/trunk/src/mathelp.f90
r440 r845 28 28 CONTAINS 29 29 !=== 30 SUBROUTINE buildop (str,ex_topps,topp,nbops_max, & 31 & missing_val,opps,scal,nbops) 30 SUBROUTINE buildop (c_str,ex_topps,topp,fill_val,opps,scal,nbops) 32 31 !--------------------------------------------------------------------- 33 32 !- This subroutine decomposes the input string in the elementary … … 39 38 !- INPUT 40 39 !- 41 !- str: String containing the operations42 !- ex_toops : T he time operations that can be expected43 !- within the string40 !- c_str : String containing the operations 41 !- ex_toops : Time operations that can be expected within the string 42 !- fill_val : 44 43 !- 45 44 !- OUTPUT 46 45 !- 47 !--------------------------------------------------------------------- 48 IMPLICIT NONE 49 !- 50 CHARACTER(LEN=80) :: str 51 CHARACTER(LEN=*) :: ex_topps 52 CHARACTER(LEN=7) :: topp 53 INTEGER :: nbops_max,nbops 54 CHARACTER(LEN=7) :: opps(nbops_max) 55 REAL :: scal(nbops_max),missing_val 56 !- 57 CHARACTER(LEN=80) :: new_str 46 !- topp : Time operation 47 !- opps : 48 !- scal : 49 !- nbops : 50 !--------------------------------------------------------------------- 51 IMPLICIT NONE 52 !- 53 CHARACTER(LEN=*),INTENT(IN) :: c_str,ex_topps 54 CHARACTER(LEN=*),INTENT(OUT) :: topp 55 CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps 56 REAL,INTENT(IN) :: fill_val 57 REAL,DIMENSION(:),INTENT(OUT) :: scal 58 INTEGER,INTENT(OUT) :: nbops 59 !- 60 CHARACTER(LEN=LEN(c_str)) :: str,new_str 58 61 INTEGER :: leng,ind_opb,ind_clb 59 62 !- … … 62 65 IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning' 63 66 !- 67 str = c_str 64 68 leng = LEN_TRIM(str) 65 69 IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN … … 94 98 & ' buildop : Call decoop ',new_str,ind_opb,ind_clb 95 99 ENDIF 96 CALL decoop (new_str, nbops_max,missing_val,opps,scal,nbops)100 CALL decoop (new_str,fill_val,opps,scal,nbops) 97 101 ELSE 98 102 CALL ipslerr(3,'buildop', & … … 115 119 END SUBROUTINE buildop 116 120 !=== 117 SUBROUTINE decoop (pstr,nbops_max,missing_val,opps,scal,nbops) 118 !--------------------------------------------------------------------- 119 IMPLICIT NONE 120 !- 121 CHARACTER(LEN=80) :: pstr 122 INTEGER :: nbops_max,nbops 123 CHARACTER(LEN=7) :: opps(nbops_max) 124 REAL :: scal(nbops_max),missing_val 125 !- 126 CHARACTER(LEN=1) :: f_char(2),s_char(2) 127 INTEGER :: nbsep,f_pos(2),s_pos(2) 121 SUBROUTINE decoop (pstr,fill_val,opps,scal,nbops) 122 !--------------------------------------------------------------------- 123 IMPLICIT NONE 124 !- 125 CHARACTER(LEN=*),INTENT(IN) :: pstr 126 REAL,INTENT(IN) :: fill_val 127 CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps 128 REAL,DIMENSION(:),INTENT(OUT) :: scal 129 INTEGER,INTENT(OUT) :: nbops 130 !- 131 CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char 132 INTEGER,DIMENSION(2) :: f_pos,s_pos 128 133 CHARACTER(LEN=20) :: opp_str,scal_str 129 CHARACTER(LEN= 80) :: str130 INTEGER :: xpos,leng,ppos,epos,int_tmp134 CHARACTER(LEN=LEN(pstr)) :: str 135 INTEGER :: nbsep,nbops_max,xpos,leng,ppos,epos,int_tmp 131 136 CHARACTER(LEN=3) :: tl,dl 132 137 CHARACTER(LEN=10) :: fmt … … 134 139 LOGICAL :: check = .FALSE.,prio 135 140 !--------------------------------------------------------------------- 136 IF (check) WRITE(*,'(2a)') ' decoop : Incoming string : ',pstr 137 !- 138 nbops = 0 139 str = pstr 141 IF (check) WRITE(*,'(2A)') ' decoop : Incoming string : ',pstr 142 !- 143 str = pstr; nbops = 0; 140 144 !- 141 145 CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos) 142 146 IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep 147 !- 148 nbops_max = min(SIZE(opps),SIZE(scal)) 149 !- 143 150 DO WHILE (nbsep > 0) 151 IF (nbops >= nbops_max) THEN 152 CALL ipslerr(3,'decoop','Expression too complex',TRIM(str),' ') 153 ENDIF 154 !-- 144 155 xpos = INDEX(str,'X') 145 156 leng = LEN_TRIM(str) … … 147 158 !-- 148 159 IF (check) THEN 149 WRITE(*,*) 'decoop : str -->',str(1:leng) 160 WRITE(*,*) 'decoop : str -> ',TRIM(str) 161 WRITE(*,*) 'decoop : nbops -> ',nbops 150 162 WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2) 151 163 WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2) 152 164 ENDIF 153 !--154 IF (nbops > nbops_max-1) THEN155 CALL ipslerr(3,'decoop','Expression too complex',str,' ')156 ENDIF157 !--158 IF (check) WRITE(*,*) 'decoop : --',nbops,' ',str(1:leng)159 165 !--- 160 166 !-- Start the analysis of the syntax. 3 types of constructs … … 236 242 IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN 237 243 opps(nbops) = opp_str(1:LEN_TRIM(opp_str)) 238 scal(nbops) = missing_val244 scal(nbops) = fill_val 239 245 ELSE 240 246 CALL ipslerr(3,'decoop', & … … 313 319 IMPLICIT NONE 314 320 !- 315 CHARACTER(LEN= 80) :: str321 CHARACTER(LEN=*),INTENT(INOUT) :: str 316 322 INTEGER :: nbsep 317 323 CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char 318 324 INTEGER,DIMENSION(2) :: f_pos,s_pos 319 325 !- 320 CHARACTER(LEN= 70) :: str_tmp326 CHARACTER(LEN=10) :: str_tmp 321 327 LOGICAL :: f_found,s_found 322 328 INTEGER :: ind,xpos,leng,i … … 385 391 WRITE(str_tmp,'("number :",I3)') nbsep 386 392 CALL ipslerr(3,'findsep', & 387 & 'How can I find that many separators',str_tmp, str)393 & 'How can I find that many separators',str_tmp,TRIM(str)) 388 394 ENDIF 389 395 !- … … 399 405 IMPLICIT NONE 400 406 !- 401 CHARACTER(LEN= 80) :: str407 CHARACTER(LEN=*),INTENT(INOUT) :: str 402 408 !- 403 409 INTEGER :: ind,leng,ic,it
Note: See TracChangeset
for help on using the changeset viewer.