Changeset 122


Ignore:
Timestamp:
08/03/07 15:42:20 (17 years ago)
Author:
bellier
Message:

JB: some cleaning (-> fortran 90)

Location:
IOIPSL/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • IOIPSL/trunk/example/testrest.f90

    r16 r122  
    22!- 
    33!$Id$ 
    4   ! 
     4!--------------------------------------------------------------------- 
     5!- This program provide a an example of the basic usage of REST. 
     6!- Here the test the time sampling and averaging. Thus a long 
     7!- time-series is produced and sampled in different ways. 
     8!--------------------------------------------------------------------- 
    59  USE ioipsl 
    6   ! 
    7   !     This program provide a an example of the basic usage of REST. 
    8   !     Here the test the time sampling and averaging. Thus a long 
    9   !     time-series is produced and sampled in different ways. 
    10   ! 
     10! 
    1111  IMPLICIT NONE 
    12   ! 
    13   INTEGER :: iim, jjm, llm 
     12! 
     13  INTEGER :: iim,jjm,llm 
    1414  PARAMETER (iim=12,jjm=10,llm=2) 
    15   ! 
    16   REAL :: champ1(iim,jjm,llm), champ2(iim,jjm,llm+1), champ3(iim,jjm,llm) 
     15! 
     16  REAL :: champ1(iim,jjm,llm),champ2(iim,jjm,llm+1),champ3(iim,jjm,llm) 
    1717  REAL :: champ4(iim,jjm) 
    1818  REAL :: champ_read(iim,jjm,llm) 
    19   REAL :: lon(iim,jjm),lat(iim,jjm), lev(llm) 
     19  REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) 
    2020  REAL :: x 
    21   ! 
    22   INTEGER :: i, j, l, fid, t, ij, sig_id, hori_id, it 
    23   INTEGER :: day=1, month=1, year=1997 
    24   INTEGER :: itau=1, start, INDEX(1) 
    25   ! 
    26   REAL :: julday, un_mois, un_an 
    27   REAL :: deltat=86400, dt_wrt, dt_op, dt_wrt2, dt_op2 
    28   CHARACTER*20 :: fnamein, fnameout, keyword, value 
    29   ! 
     21! 
     22  INTEGER :: i,j,l,fid,t,ij,sig_id,hori_id,it 
     23  INTEGER :: day=1,month=1,year=1997 
     24  INTEGER :: itau=1,start,INDEX(1) 
     25! 
     26  REAL :: julday,un_mois,un_an 
     27  REAL :: deltat=86400,dt_wrt,dt_op,dt_wrt2,dt_op2 
     28  CHARACTER*20 :: fnamein,fnameout,keyword,value 
     29! 
    3030  REAL :: pi=3.1415 
    31   ! 
    32   !     0.0 Choose a  gregorian calendar 
    33   ! 
    34   CALL ioconf_calendar('gregorian') 
    35   ! 
    36   !     1.0 Define a few variables we will need. These are the coordinates 
    37   !         the file name and the date. 
    38   ! 
    39   DO i = 1, iim 
    40     DO j = 1, jjm 
    41       lon(i,j) = ((float(iim/2)+0.5)-float(i))*pi/float(iim/2) & 
    42          &           *(-1.)*180./pi 
    43       lat(i,j) = 180./pi * ASIN(((float(jjm/2)+0.5) - float(j)) & 
    44          &           /float(jjm/2)) 
     31!--------------------------------------------------------------------- 
     32!- 
     33! 0.0 Choose a  gregorian calendar 
     34!- 
     35  CALL ioconf_calendar ('gregorian') 
     36!- 
     37! 1.0 Define a few variables we will need. 
     38!     These are the coordinates the file name and the date. 
     39!- 
     40  DO i=1,iim 
     41    DO j=1,jjm 
     42      lon(i,j) = & 
     43 &     ((float(iim/2)+0.5)-float(i))*pi/float(iim/2)*(-1.)*180./pi 
     44      lat(i,j) = & 
     45 &     (180./pi)*ASIN(((float(jjm/2)+0.5)-float(j))/float(jjm/2)) 
    4546    ENDDO 
    4647  ENDDO 
    47   ! 
     48!- 
    4849  DO l=1,llm 
    4950    lev(l) = float(l)/llm 
    5051  ENDDO 
    51   ! 
    52   !    1.1 The chosen date is 15 Feb. 1997 as stated above. It has to be  
    53   !         transformed into julian days using the calendar provided by  
    54   !         IOIPSL. 
    55   ! 
    56   CALL ymds2ju(year, month, day, 0.,julday) 
    57   CALL ioget_calendar(un_an) 
     52!- 
     53! 1.1 The chosen date is 15 Feb. 1997 as stated above. It has to be  
     54!     transformed into julian days using the calendar provided by  
     55!     IOIPSL. 
     56!- 
     57  CALL ymds2ju (year,month,day,0.,julday) 
     58  CALL ioget_calendar (un_an) 
    5859  un_mois = un_an/12. 
    5960  dt_wrt = un_mois*deltat 
    … …  
    6162  dt_wrt2 = -1. 
    6263  dt_op2 = deltat 
    63   ! 
    64   ! 
     64!- 
    6565  fnamein = 'NONE' 
    6666  fnameout = 'restfile' 
    67   ! 
    68   ! 2.0 Create a restart file from nothing ! 
    69   ! 
    70   CALL restini(fnamein, iim, jjm, lon, lat, llm, lev, fnameout, & 
    71      &     itau, julday, deltat, fid) 
    72   ! 
     67!- 
     68! 2.0 Create a restart file from nothing ! 
     69!- 
     70  CALL restini (fnamein,iim,jjm,lon,lat,llm,lev,fnameout, & 
     71 &              itau,julday,deltat,fid) 
     72!- 
    7373  champ1(:,:,:) = ASIN(1.0) 
    7474  champ2(:,:,:) = EXP(ASIN(1.0)) 
    75   ! 
    76   CALL ioconf_setatt('units', '?') 
    77   CALL ioconf_setatt('long_name', 'Tests 1 for a real variable') 
    78   CALL restput(fid, 'test1', iim, jjm, llm, itau, champ1) 
    79   ! 
    80   CALL ioconf_setatt('units', '?') 
    81   CALL ioconf_setatt('long_name', 'Tests 2 for a real variable') 
    82   CALL restput(fid, 'test2', iim, jjm, llm+1, itau, champ2) 
    83   ! 
    84   CALL restclo() 
    85   ! 
     75!- 
     76  CALL ioconf_setatt ('units','?') 
     77  CALL ioconf_setatt ('long_name','Tests 1 for a real variable') 
     78  CALL restput (fid,'test1',iim,jjm,llm,itau,champ1) 
     79!- 
     80  CALL ioconf_setatt ('units','?') 
     81  CALL ioconf_setatt ('long_name','Tests 2 for a real variable') 
     82  CALL restput (fid,'test2',iim,jjm,llm+1,itau,champ2) 
     83!- 
     84  CALL restclo () 
     85!- 
    8686  WRITE(*,*) '============== FIRST FILE CLOSED ==============' 
    87   ! 
    88   !  3.0 Reopen the restart file and check that the values read are correct 
    89   ! 
     87!- 
     88!  3.0 Reopen the restart file and check that the values read are correct 
     89!- 
    9090  fnamein = 'restfile' 
    9191  fnameout = 'restfilebis' 
    92   ! 
    93   !  
    94   CALL restini(fnamein, iim, jjm, lon, lat, llm, lev, fnameout, & 
    95      &     itau, julday, deltat, fid) 
    96   ! 
    97   CALL restget(fid, 'test1', iim, jjm, llm,itau, .FALSE., champ_read) 
    98   ! 
     92!- 
     93  CALL restini (fnamein,iim,jjm,lon,lat,llm,lev,fnameout, & 
     94 &              itau,julday,deltat,fid) 
     95!- 
     96  CALL restget (fid,'test1',iim,jjm,llm,itau,.FALSE.,champ_read) 
     97!- 
    9998  itau = itau+10 
    100   CALL restput(fid, 'test1', iim, jjm, llm, itau, champ_read) 
    101   CALL restput(fid, 'test2', iim, jjm, llm+1, itau, champ2) 
    102   ! 
    103   itau = itau + 10 
    104   champ3(:,:,:) = champ_read(:,:,:) + champ2(:,:,1:llm)  
    105   CALL restput(fid, 'test1', iim, jjm, llm, itau, champ3) 
    106   ! 
    107   CALL restclo() 
    108   ! 
     99  CALL restput (fid,'test1',iim,jjm,llm,itau,champ_read) 
     100  CALL restput (fid,'test2',iim,jjm,llm+1,itau,champ2) 
     101!- 
     102  itau = itau+10 
     103  champ3(:,:,:) = champ_read(:,:,:)+champ2(:,:,1:llm)  
     104  CALL restput (fid,'test1',iim,jjm,llm,itau,champ3) 
     105!- 
     106  CALL restclo () 
     107!- 
    109108  WRITE(*,'(a25,e36.30)') 'The input data : ',champ1(1,1,1) 
    110109  WRITE(*,'(a25,e36.30)') 'The restart data : ',champ_read(1,1,1) 
    111   ! 
    112   !  4.0 Reopen the restart file and add another time step 
    113   ! 
     110!- 
     111!  4.0 Reopen the restart file and add another time step 
     112!- 
    114113  fnamein = 'restfilebis' 
    115114  fnameout = 'restfilebis' 
    116   ! 
    117   !  
    118   CALL restini(fnamein, iim, jjm, lon, lat, llm, lev, fnameout, & 
    119      &     itau, julday, deltat, fid) 
    120   ! 
    121   itau = itau + 10 
    122   CALL restput(fid, 'test1', iim, jjm, llm, itau, champ1) 
    123   CALL ioconf_setatt('units', '?') 
    124   CALL ioconf_setatt('long_name', 'Test a variable with another dimension') 
    125   CALL restput(fid, 'test4', iim, jjm, 0, itau, champ4) 
    126   ! 
    127   CALL restclo() 
    128   ! 
    129   STOP 
    130   ! 
     115!- 
     116  CALL restini (fnamein,iim,jjm,lon,lat,llm,lev,fnameout, & 
     117 &              itau,julday,deltat,fid) 
     118!- 
     119  itau = itau+10 
     120  CALL restput (fid,'test1',iim,jjm,llm,itau,champ1) 
     121  CALL ioconf_setatt ('units','?') 
     122  CALL ioconf_setatt ('long_name', & 
     123 &                    'Test a variable with another dimension') 
     124  CALL restput (fid,'test4',iim,jjm,0,itau,champ4) 
     125!- 
     126  CALL restclo () 
     127!------------------- 
    131128END PROGRAM testrest 
    132  

  • IOIPSL/trunk/src/histcom.f90

    r75 r122  
    106106  INTEGER,SAVE :: nb_zax(nb_files_max)=0 
    107107  INTEGER,DIMENSION(nb_files_max,nb_zax_max),SAVE :: & 
    108   &  zax_size,zax_ids,zax_name_length 
     108  &  zax_size,zax_ids 
    109109  CHARACTER(LEN=20),SAVE :: zax_name(nb_files_max,nb_zax_max) 
    110110!- 
    … …  
    112112!- 
    113113  INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 
    114  &  name_length,nbopp 
     114 &  nbopp 
    115115  CHARACTER(LEN=20),DIMENSION(nb_files_max,nb_var_max),SAVE :: & 
    116116 &  name,unit_name 
    … …  
    149149!- 
    150150  INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 
    151  &  tdimid,tax_last,tax_name_length 
     151 &  tdimid,tax_last 
    152152  CHARACTER(LEN=40),DIMENSION(nb_files_max,nb_var_max),SAVE :: & 
    153153 &  tax_name 
    … …  
    824824  ncid = ncdf_ids(pfileid) 
    825825!- 
    826   IF ( SIZE(plon_bounds, DIM=1) == pim ) THEN 
    827     nbbounds = SIZE(plon_bounds, DIM=2) 
     826  IF     ( SIZE(plon_bounds,DIM=1) == pim ) THEN 
     827    nbbounds = SIZE(plon_bounds,DIM=2) 
    828828    transp = .TRUE. 
    829   ELSEIF ( SIZE(plon_bounds, DIM=2) == pim ) THEN 
    830     nbbounds = SIZE(plon_bounds, DIM=1) 
     829  ELSEIF ( SIZE(plon_bounds,DIM=2) == pim ) THEN 
     830    nbbounds = SIZE(plon_bounds,DIM=1) 
    831831    transp = .FALSE. 
    832832  ELSE 
    … …  
    980980!- 
    981981  INTEGER :: pos, iv, nb, zdimid, zaxid_tmp 
    982   CHARACTER(LEN=20) :: str20, tab_str20(nb_zax_max) 
    983   INTEGER tab_str20_length(nb_zax_max) 
     982  CHARACTER(LEN=20) :: str20 
    984983  CHARACTER(LEN=70) :: str70, str71, str72 
    985984  CHARACTER(LEN=80) :: str80 
    … …  
    10291028    str20 = pzaxname 
    10301029    nb = iv-1 
    1031     tab_str20(1:nb) = zax_name(pfileid,1:nb) 
    1032     tab_str20_length(1:nb) = zax_name_length(pfileid,1:nb) 
    1033     CALL find_str(nb, tab_str20, tab_str20_length, str20, pos) 
     1030    CALL find_str (zax_name(pfileid,1:nb),str20,pos) 
    10341031  ELSE 
    10351032    pos = 0 
    … …  
    10381035  IF ( pos > 0) THEN 
    10391036    str70 = "Vertical axis already exists" 
    1040     WRITE(str71,'("Check variable ",a," in file",I3)') str20,pfileid 
     1037    WRITE(str71,'("Check variable ",A," in file",I3)') str20,pfileid 
    10411038    str72 = "Can also be a wrong file ID in another declaration" 
    10421039    CALL ipslerr (3,"histvert", str70, str71, str72) 
    … …  
    10851082  zax_size(pfileid, iv) = pzsize 
    10861083  zax_name(pfileid, iv) = pzaxname 
    1087   zax_name_length(pfileid, iv) = LEN_TRIM(pzaxname) 
    10881084  zax_ids(pfileid, iv) = zaxid_tmp 
    10891085  pzaxid =  iv 
    … …  
    11551151  CHARACTER(LEN=70) :: str70, str71, str72 
    11561152  CHARACTER(LEN=20) :: tmp_name 
    1157   CHARACTER(LEN=20) :: str20, tab_str20(nb_var_max) 
    1158   INTEGER :: tab_str20_length(nb_var_max) 
     1153  CHARACTER(LEN=20) :: str20 
    11591154  CHARACTER(LEN=40) :: str40, tab_str40(nb_var_max) 
    1160   INTEGER :: tab_str40_length(nb_var_max) 
    11611155  CHARACTER(LEN=10) :: str10 
    11621156  CHARACTER(LEN=80) :: tmp_str80 
    … …  
    11881182    str20 = pvarname 
    11891183    nb = iv-1 
    1190     tab_str20(1:nb) = name(pfileid,1:nb) 
    1191     tab_str20_length(1:nb) = name_length(pfileid,1:nb) 
    1192     CALL find_str (nb, tab_str20, tab_str20_length, str20, pos) 
     1184    CALL find_str (name(pfileid,1:nb),str20,pos) 
    11931185  ELSE 
    11941186    pos = 0 
    … …  
    12031195!- 
    12041196  name(pfileid,iv) = pvarname 
    1205   name_length(pfileid,iv) = LEN_TRIM(name(pfileid,iv)) 
    12061197  title(pfileid,iv) = ptitle 
    12071198  unit_name(pfileid,iv) = punit 
    … …  
    13061297 &            "to the size of the chosen vertical axis" 
    13071298      WRITE(str71,'("Size of zoom in z :", I4)') par_szz 
    1308       WRITE(str72,'("Size declared for axis ",a," :",I4)') & 
     1299      WRITE(str72,'("Size declared for axis ",A," :",I4)') & 
    13091300 &     TRIM(str20), zax_size(pfileid,pzid) 
    13101301      CALL ipslerr (3,"histdef", str70, str71, str72) 
    … …  
    14761467  ENDIF 
    14771468!- 
    1478   DO i=1,nb_tax(pfileid) 
    1479     tab_str40(i) = tax_name(pfileid,i) 
    1480     tab_str40_length(i) = tax_name_length(pfileid,i) 
    1481   ENDDO 
    1482 !- 
    1483   CALL find_str (nb_tax(pfileid),tab_str40,tab_str40_length,str40,pos) 
     1469  tab_str40(1:nb_tax(pfileid)) = tax_name(pfileid,1:nb_tax(pfileid)) 
     1470  CALL find_str (tab_str40(1:nb_tax(pfileid)),str40,pos) 
    14841471!- 
    14851472! No time axis for once, l_max, l_min or never operation 
    … …  
    14921479      nb_tax(pfileid) = nb_tax(pfileid)+1 
    14931480      tax_name(pfileid,nb_tax(pfileid)) = str40 
    1494       tax_name_length(pfileid, nb_tax(pfileid)) = LEN_TRIM(str40) 
    14951481      tax_last(pfileid,nb_tax(pfileid)) = 0 
    14961482      var_axid(pfileid,iv) = nb_tax(pfileid) 
    … …  
    24712457  INTEGER,SAVE :: varseq_err(nb_files_max) = 0 
    24722458  INTEGER      :: ib, nb, sp, nx, pos 
    2473   CHARACTER(LEN=20),DIMENSION(nb_var_max) :: tab_str20 
    24742459  CHARACTER(LEN=20) :: str20 
    24752460  CHARACTER(LEN=70) :: str70 
    2476   INTEGER      :: tab_str20_length(nb_var_max) 
    24772461!- 
    24782462  LOGICAL :: check = .FALSE. 
    … …  
    25002484!- 
    25012485    str20 = pvarname 
    2502     tab_str20(1:nb) = name(pfid,1:nb) 
    2503     tab_str20_length(1:nb) = name_length(pfid,1:nb) 
    2504 !- 
    2505     CALL find_str (nb, tab_str20, tab_str20_length, str20, pos) 
     2486    CALL find_str (name(pfid,1:nb),str20,pos) 
    25062487!- 
    25072488    IF (pos > 0) THEN 
    … …  
    25652546    pvid = varseq(pfid, nx) 
    25662547!- 
    2567     IF (    (INDEX(name(pfid,pvid),pvarname) <= 0)         & 
    2568    &    .OR.(name_length(pfid,pvid) /= len_trim(pvarname)) ) THEN 
     2548    IF ( TRIM(name(pfid,pvid)) /= TRIM(pvarname) ) THEN 
    25692549      str20 = pvarname 
    2570       tab_str20(1:nb) = name(pfid,1:nb) 
    2571       tab_str20_length(1:nb) = name_length(pfid,1:nb) 
    2572       CALL find_str (nb,tab_str20,tab_str20_length,str20,pos) 
     2550      CALL find_str (name(pfid,1:nb),str20,pos) 
    25732551      IF (pos > 0) THEN 
    25742552        pvid = pos 

  • IOIPSL/trunk/src/restcom.f90

    r11 r122  
    126126 &  varname_in,varname_out 
    127127  INTEGER,DIMENSION(max_file,max_var),SAVE :: & 
    128  &  varname_in_length,varname_out_length, & 
    129128 &  varid_in,varid_out,varnbdim_in,varatt_in 
    130129  INTEGER,DIMENSION(max_file,max_var,max_dim),SAVE :: & 
    … …  
    357356    netcdf_id(nbfiles,2) = netcdf_id(nbfiles,1) 
    358357    varname_out(nbfiles,:) = varname_in(nbfiles,:)  
    359     varname_out_length(nbfiles,:) = varname_in_length(nbfiles,:)  
    360358    nbvar_out(nbfiles) = nbvar_in(nbfiles)  
    361359    tind_varid_out(nbfiles) = tind_varid_in(nbfiles)  
    … …  
    550548    ENDDO 
    551549!--- 
    552     varname_in_length(fid,iv) = LEN_TRIM(varname_in(fid,iv)) 
    553 !--- 
    554550!-- 2.1 Read the units of the variable 
    555551!--- 
    … …  
    14871483  ncfid = netcdf_id(fid,1) 
    14881484!- 
    1489   CALL find_str & 
    1490     (nbvar_in(fid),varname_in(fid,1:nbvar_in(fid)), & 
    1491      varname_in_length(fid,1:nbvar_in(fid)),vname_q,vnb) 
     1485  CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb) 
    14921486!- 
    14931487! 1.0 If the variable is not present then ERROR or filled up 
    … …  
    15131507      vnb = nbvar_in(fid) 
    15141508      varname_in(fid,vnb) = vname_q 
    1515       varname_in_length(fid,vnb) = LEN_TRIM(vname_q) 
    15161509      touched_in(fid,vnb) = .TRUE. 
    15171510!----- 
    … …  
    21182111  IF (check) WRITE(*,*) 'RESTPUT 1.0 : ',TRIM(vname_q) 
    21192112!- 
    2120   CALL find_str & 
    2121     (nbvar_out(fid),varname_out(fid,1:nbvar_out(fid)), & 
    2122      varname_out_length(fid,1:nbvar_out(fid)),vname_q,vnb) 
     2113  CALL find_str (varname_out(fid,1:nbvar_out(fid)),vname_q,vnb) 
    21232114!- 
    21242115  IF (check) THEN 
    … …  
    22652256  nbvar_out(fid) = nbvar_out(fid)+1 
    22662257  varname_out(fid,nbvar_out(fid)) = varname 
    2267   varname_out_length(fid,nbvar_out(fid)) = LEN_TRIM(varname) 
    22682258!- 
    22692259! 0.0 Put the file in define mode if needed 
    … …  
    24412431!--------------------------------------------------------------------- 
    24422432! Find the index of the variable 
    2443   CALL find_str & 
    2444     (nbvar_in(fid),varname_in(fid,1:nbvar_in(fid)), & 
    2445      varname_in_length(fid,1:nbvar_in(fid)),vname_q,vnb) 
     2433  CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb) 
    24462434!- 
    24472435  IF (vnb > 0) THEN 

  • IOIPSL/trunk/src/stringop.f90

    r19 r122  
    7676END FUNCTION findpos 
    7777!=== 
    78 SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos) 
     78SUBROUTINE find_str (str_tab,str,pos) 
    7979!--------------------------------------------------------------------- 
    8080!- This subroutine looks for a string in a table 
    8181!--------------------------------------------------------------------- 
    8282!- INPUT 
    83 !-   nb_str      : length of table 
    84 !-   str_tab     : Table  of strings 
    85 !-   str_len_tab : Table  of string-length 
    86 !-   str         : Target we are looking for 
     83!-   str_tab  : Table  of strings 
     84!-   str      : Target we are looking for 
    8785!- OUTPUT 
    88 !-   pos         : -1 if str not found, else value in the table 
    89 !--------------------------------------------------------------------- 
    90   IMPLICIT NONE 
    91 !- 
    92   INTEGER :: nb_str 
    93   CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab 
    94   INTEGER,DIMENSION(nb_str) :: str_len_tab 
    95   CHARACTER(LEN=*) :: str 
    96   INTEGER :: pos 
    97 !- 
    98   INTEGER :: i,il 
     86!-   pos      : -1 if str not found, else value in the table 
     87!--------------------------------------------------------------------- 
     88  IMPLICIT NONE 
     89!- 
     90  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab 
     91  CHARACTER(LEN=*),INTENT(in) :: str 
     92  INTEGER,INTENT(out) :: pos 
     93!- 
     94  INTEGER :: nb_str,i 
    9995!--------------------------------------------------------------------- 
    10096  pos = -1 
    101   il = LEN_TRIM(str) 
     97  nb_str=SIZE(str_tab) 
    10298  IF ( nb_str > 0 ) THEN 
    10399    DO i=1,nb_str 
    104       IF (     (INDEX(str_tab(i),str(1:il)) > 0) & 
    105           .AND.(str_len_tab(i) == il) ) THEN 
     100      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN 
    106101        pos = i 
    107102        EXIT 
Note: See TracChangeset for help on using the changeset viewer.