Changeset 845


Ignore:
Timestamp:
12/10/09 17:26:03 (15 years ago)
Author:
bellier
Message:

Update to FORTRAN 90

Location:
IOIPSL/trunk/src
Files:
2 edited

Legend:

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

    r806 r845  
    8888  CHARACTER(LEN=80) :: title,std_name,fullop 
    8989  CHARACTER(LEN=7)  :: topp 
    90   CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopps 
     90  CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp 
    9191  REAL,DIMENSION(nbopp_max) :: scal 
    9292!-External type (for R4/R8) 
     
    11581158  CHARACTER(LEN=40) :: str40 
    11591159  CHARACTER(LEN=10) :: str10 
    1160   CHARACTER(LEN=80) :: tmp_str80 
    1161   CHARACTER(LEN=7) :: tmp_topp,tmp_sopp(nbopp_max) 
    11621160  CHARACTER(LEN=120) :: ex_topps 
    1163   REAL :: tmp_scal(nbopp_max),un_an,un_jour,test_fopp,test_fwrt 
     1161  REAL :: un_an,un_jour,test_fopp,test_fwrt 
    11641162  INTEGER :: pos,buff_sz 
    11651163  LOGICAL :: l_dbg 
     
    12111209!- 
    12121210  W_F(pfileid)%W_V(iv)%fullop = popp 
    1213   tmp_str80 = popp 
    12141211  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) 
    12231215!- 
    12241216! 1.2 If we have an even number of operations 
    12251217!     then we need to add identity 
    12261218!- 
    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 
    12291220    W_F(pfileid)%W_V(iv)%nbopp = W_F(pfileid)%W_V(iv)%nbopp+1 
    1230     W_F(pfileid)%W_V(iv)%sopps(W_F(pfileid)%W_V(iv)%nbopp) = 'ident' 
     1221    W_F(pfileid)%W_V(iv)%sopp(W_F(pfileid)%W_V(iv)%nbopp) = 'ident' 
    12311222    W_F(pfileid)%W_V(iv)%scal(W_F(pfileid)%W_V(iv)%nbopp) = missing_val 
    12321223  ENDIF 
     
    12441235  IF (l_dbg) THEN 
    12451236    WRITE(*,*) "histdef : 2.0",pfileid,iv,W_F(pfileid)%W_V(iv)%nbopp, & 
    1246  &    W_F(pfileid)%W_V(iv)%sopps(1:W_F(pfileid)%W_V(iv)%nbopp), & 
     1237 &    W_F(pfileid)%W_V(iv)%sopp(1:W_F(pfileid)%W_V(iv)%nbopp), & 
    12471238 &    W_F(pfileid)%W_V(iv)%scal(1:W_F(pfileid)%W_V(iv)%nbopp) 
    12481239  ENDIF 
     
    13481339!     which need bufferisation 
    13491340!- 
    1350   IF (     (TRIM(tmp_topp) /= "inst") & 
    1351  &    .AND.(TRIM(tmp_topp) /= "once") & 
    1352  &    .AND.(TRIM(tmp_topp) /= "never") )THEN 
     1341  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 
    13531344    W_F(pfileid)%W_V(iv)%point = buff_pos+1 
    13541345    buff_pos = buff_pos+buff_sz 
     
    14101401!     its compaticility with the choice of frequencies 
    14111402!- 
    1412   IF (TRIM(tmp_topp) == "inst") THEN 
     1403  IF (TRIM(W_F(pfileid)%W_V(iv)%topp) == "inst") THEN 
    14131404    IF (test_fopp /= test_fwrt) THEN 
    14141405      str70 = 'For instantaneous output the frequency '// & 
     
    14271418      ENDIF 
    14281419    ENDIF 
    1429   ELSE IF (INDEX(ex_topps,TRIM(tmp_topp)) > 0) THEN 
     1420  ELSE IF (INDEX(ex_topps,TRIM(W_F(pfileid)%W_V(iv)%topp)) > 0) THEN 
    14301421    IF (test_fopp > test_fwrt) THEN 
    14311422      str70 = 'For averages the frequency of operations '// & 
    1432 &             'should be smaller or equal' 
     1423 &            'should be smaller or equal' 
    14331424      WRITE(str71, & 
    14341425 &     '("to that of output. It is not the case for variable ",a)') & 
     
    14391430    ENDIF 
    14401431  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 
    14441436    WRITE (str72,'("File ID :",I3)') pfileid 
    14451437    CALL ipslerr (3,"histdef",str70,str71,str72) 
     
    14781470  IF (W_F(pfileid)%W_V(iv)%freq_wrt > 0) THEN 
    14791471    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) 
    14811473  ELSE 
    14821474    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) 
    14841476  ENDIF 
    14851477  CALL find_str (W_F(pfileid)%W_V(1:W_F(pfileid)%n_tax)%tax_name,str40,pos) 
     
    14871479! No time axis for once, l_max, l_min or never operation 
    14881480!- 
    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') ) THEN 
     1481  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 
    14931485    IF (pos < 0) THEN 
    14941486      W_F(pfileid)%n_tax = W_F(pfileid)%n_tax+1 
     
    15001492    ENDIF 
    15011493  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 
    15031497    W_F(pfileid)%W_V(iv)%t_axid = -99 
    15041498  ENDIF 
     
    15071501!     for never or once operation 
    15081502!- 
    1509   IF (    (TRIM(tmp_topp) == 'once')  & 
    1510  &    .OR.(TRIM(tmp_topp) == 'never') ) THEN 
     1503  IF (    (TRIM(W_F(pfileid)%W_V(iv)%topp) == 'once')  & 
     1504 &    .OR.(TRIM(W_F(pfileid)%W_V(iv)%topp) == 'never') ) THEN 
    15111505    W_F(pfileid)%W_V(iv)%freq_opp = 0. 
    15121506    W_F(pfileid)%W_V(iv)%freq_wrt = 0. 
     
    18961890      largebuf = .FALSE. 
    18971891      DO io=1,W_F(pfileid)%W_V(varid)%nbopp 
    1898         IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopps(io)) > 0) THEN 
     1892        IF (INDEX(fuchnbout,W_F(pfileid)%W_V(varid)%sopp(io)) > 0) THEN 
    18991893          largebuf = .TRUE. 
    19001894        ENDIF 
     
    19481942    IF      (l1d) THEN 
    19491943      nbpt_in1 = W_F(pfileid)%W_V(varid)%datasz_in(1) 
    1950       CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in1,pdata_1d, & 
     1944      CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in1,pdata_1d, & 
    19511945 &                 missing_val,nbindex,nindex, & 
    19521946 &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 
    19531947    ELSE IF (l2d) THEN 
    19541948      nbpt_in2(1:2) = W_F(pfileid)%W_V(varid)%datasz_in(1:2) 
    1955       CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in2,pdata_2d, & 
     1949      CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in2,pdata_2d, & 
    19561950 &                 missing_val,nbindex,nindex, & 
    19571951 &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 
    19581952    ELSE IF (l3d) THEN 
    19591953      nbpt_in3(1:3) = W_F(pfileid)%W_V(varid)%datasz_in(1:3) 
    1960       CALL mathop (W_F(pfileid)%W_V(varid)%sopps(1),nbpt_in3,pdata_3d, & 
     1954      CALL mathop (W_F(pfileid)%W_V(varid)%sopp(1),nbpt_in3,pdata_3d, & 
    19611955 &                 missing_val,nbindex,nindex, & 
    19621956 &                 W_F(pfileid)%W_V(varid)%scal(1),nbpt_out,buff_tmp) 
     
    20902084      nbin = nbout 
    20912085      nbout = W_F(i)%W_V(varid)%datasz_max 
    2092       CALL mathop(W_F(i)%W_V(varid)%sopps(io),nbin,buff_tmp, & 
     2086      CALL mathop(W_F(i)%W_V(varid)%sopp(io),nbin,buff_tmp, & 
    20932087 &      missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io), & 
    20942088 &      nbout,buff_tmp2) 
    20952089      IF (l_dbg) THEN 
    20962090        WRITE(*,*) & 
    2097  &       "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io) 
     2091 &       "histwrite: 3.4a nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp(io) 
    20982092      ENDIF 
    20992093!- 
    21002094      nbin = nbout 
    21012095      nbout = W_F(i)%W_V(varid)%datasz_max 
    2102       CALL mathop(W_F(i)%W_V(varid)%sopps(io+1),nbin,buff_tmp2, & 
     2096      CALL mathop(W_F(i)%W_V(varid)%sopp(io+1),nbin,buff_tmp2, & 
    21032097 &      missing_val,nbindex,nindex,W_F(i)%W_V(varid)%scal(io+1), & 
    21042098 &      nbout,buff_tmp) 
    21052099      IF (l_dbg) THEN 
    21062100        WRITE(*,*) & 
    2107  &     "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopps(io+1) 
     2101 &     "histwrite: 3.4b nbout : ",nbin,nbout,W_F(i)%W_V(varid)%sopp(io+1) 
    21082102      ENDIF 
    21092103    ENDDO 
  • IOIPSL/trunk/src/mathelp.f90

    r440 r845  
    2828CONTAINS 
    2929!=== 
    30 SUBROUTINE buildop (str,ex_topps,topp,nbops_max, & 
    31  &                  missing_val,opps,scal,nbops) 
     30SUBROUTINE buildop (c_str,ex_topps,topp,fill_val,opps,scal,nbops) 
    3231!--------------------------------------------------------------------- 
    3332!- This subroutine decomposes the input string in the elementary 
     
    3938!- INPUT 
    4039!- 
    41 !- str      : String containing the operations 
    42 !- ex_toops : The time operations that can be expected 
    43 !-            within the string 
     40!- c_str    : String containing the operations 
     41!- ex_toops : Time operations that can be expected within the string 
     42!- fill_val : 
    4443!- 
    4544!- OUTPUT 
    4645!- 
    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 
    5861  INTEGER :: leng,ind_opb,ind_clb 
    5962!- 
     
    6265  IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning' 
    6366!- 
     67  str = c_str 
    6468  leng = LEN_TRIM(str) 
    6569  IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN 
     
    9498 &          ' buildop : Call decoop ',new_str,ind_opb,ind_clb 
    9599        ENDIF 
    96         CALL decoop (new_str,nbops_max,missing_val,opps,scal,nbops) 
     100        CALL decoop (new_str,fill_val,opps,scal,nbops) 
    97101      ELSE 
    98102        CALL ipslerr(3,'buildop', & 
     
    115119END SUBROUTINE buildop 
    116120!=== 
    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) 
     121SUBROUTINE 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 
    128133  CHARACTER(LEN=20) :: opp_str,scal_str 
    129   CHARACTER(LEN=80) :: str 
    130   INTEGER :: xpos,leng,ppos,epos,int_tmp 
     134  CHARACTER(LEN=LEN(pstr)) :: str 
     135  INTEGER :: nbsep,nbops_max,xpos,leng,ppos,epos,int_tmp 
    131136  CHARACTER(LEN=3) :: tl,dl 
    132137  CHARACTER(LEN=10) :: fmt 
     
    134139  LOGICAL :: check = .FALSE.,prio 
    135140!--------------------------------------------------------------------- 
    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; 
    140144!- 
    141145  CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos) 
    142146  IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep 
     147!- 
     148  nbops_max = min(SIZE(opps),SIZE(scal)) 
     149!- 
    143150  DO WHILE (nbsep > 0) 
     151    IF (nbops >= nbops_max) THEN 
     152      CALL ipslerr(3,'decoop','Expression too complex',TRIM(str),' ') 
     153    ENDIF 
     154!-- 
    144155    xpos = INDEX(str,'X') 
    145156    leng = LEN_TRIM(str) 
     
    147158!-- 
    148159    IF (check) THEN 
    149       WRITE(*,*) 'decoop : str -->',str(1:leng) 
     160      WRITE(*,*) 'decoop : str   -> ',TRIM(str) 
     161      WRITE(*,*) 'decoop : nbops -> ',nbops 
    150162      WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2) 
    151163      WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2) 
    152164    ENDIF 
    153 !-- 
    154     IF (nbops > nbops_max-1) THEN 
    155       CALL ipslerr(3,'decoop','Expression too complex',str,' ') 
    156     ENDIF 
    157 !-- 
    158     IF (check) WRITE(*,*) 'decoop : --',nbops,' ',str(1:leng) 
    159165!--- 
    160166!-- Start the analysis of the syntax. 3 types of constructs 
     
    236242      IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN 
    237243        opps(nbops) = opp_str(1:LEN_TRIM(opp_str)) 
    238         scal(nbops) =  missing_val 
     244        scal(nbops) = fill_val 
    239245      ELSE 
    240246        CALL ipslerr(3,'decoop', & 
     
    313319  IMPLICIT NONE 
    314320!- 
    315   CHARACTER(LEN=80) :: str 
     321  CHARACTER(LEN=*),INTENT(INOUT) :: str 
    316322  INTEGER :: nbsep 
    317323  CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char 
    318324  INTEGER,DIMENSION(2) :: f_pos,s_pos 
    319325!- 
    320   CHARACTER(LEN=70) :: str_tmp 
     326  CHARACTER(LEN=10) :: str_tmp 
    321327  LOGICAL :: f_found,s_found 
    322328  INTEGER :: ind,xpos,leng,i 
     
    385391    WRITE(str_tmp,'("number :",I3)') nbsep 
    386392    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)) 
    388394  ENDIF 
    389395!- 
     
    399405  IMPLICIT NONE 
    400406!- 
    401   CHARACTER(LEN=80) :: str 
     407  CHARACTER(LEN=*),INTENT(INOUT) :: str 
    402408!- 
    403409  INTEGER :: ind,leng,ic,it 
Note: See TracChangeset for help on using the changeset viewer.