Changeset 122 for IOIPSL/trunk
- Timestamp:
- 08/03/07 15:42:20 (17 years ago)
- Location:
- IOIPSL/trunk
- Files:
-
- 4 edited
-
example/testrest.f90 (modified) (2 diffs)
-
src/histcom.f90 (modified) (17 diffs)
-
src/restcom.f90 (modified) (8 diffs)
-
src/stringop.f90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/example/testrest.f90
r16 r122 2 2 !- 3 3 !$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 !--------------------------------------------------------------------- 5 9 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 ! 11 11 IMPLICIT NONE 12 13 INTEGER :: iim, jjm,llm12 ! 13 INTEGER :: iim,jjm,llm 14 14 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) 17 17 REAL :: champ4(iim,jjm) 18 18 REAL :: champ_read(iim,jjm,llm) 19 REAL :: lon(iim,jjm),lat(iim,jjm), 19 REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) 20 20 REAL :: x 21 22 INTEGER :: i, j, l, fid, t, ij, sig_id, hori_id,it23 INTEGER :: day=1, month=1,year=199724 INTEGER :: itau=1, start,INDEX(1)25 26 REAL :: julday, un_mois,un_an27 REAL :: deltat=86400, dt_wrt, dt_op, dt_wrt2,dt_op228 CHARACTER*20 :: fnamein, fnameout, keyword,value29 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 ! 30 30 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)) 45 46 ENDDO 46 47 ENDDO 47 ! 48 !- 48 49 DO l=1,llm 49 50 lev(l) = float(l)/llm 50 51 ENDDO 51 ! 52 !1.1 The chosen date is 15 Feb. 1997 as stated above. It has to be53 !transformed into julian days using the calendar provided by54 !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) 58 59 un_mois = un_an/12. 59 60 dt_wrt = un_mois*deltat … … 61 62 dt_wrt2 = -1. 62 63 dt_op2 = deltat 63 ! 64 ! 64 !- 65 65 fnamein = 'NONE' 66 66 fnameout = 'restfile' 67 ! 68 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 !- 73 73 champ1(:,:,:) = ASIN(1.0) 74 74 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 !- 86 86 WRITE(*,*) '============== FIRST FILE CLOSED ==============' 87 ! 88 89 ! 87 !- 88 ! 3.0 Reopen the restart file and check that the values read are correct 89 !- 90 90 fnamein = 'restfile' 91 91 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 !- 99 98 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 +10104 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 !- 109 108 WRITE(*,'(a25,e36.30)') 'The input data : ',champ1(1,1,1) 110 109 WRITE(*,'(a25,e36.30)') 'The restart data : ',champ_read(1,1,1) 111 ! 112 113 ! 110 !- 111 ! 4.0 Reopen the restart file and add another time step 112 !- 114 113 fnamein = 'restfilebis' 115 114 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 !------------------- 131 128 END PROGRAM testrest 132 -
IOIPSL/trunk/src/histcom.f90
r75 r122 106 106 INTEGER,SAVE :: nb_zax(nb_files_max)=0 107 107 INTEGER,DIMENSION(nb_files_max,nb_zax_max),SAVE :: & 108 & zax_size,zax_ids ,zax_name_length108 & zax_size,zax_ids 109 109 CHARACTER(LEN=20),SAVE :: zax_name(nb_files_max,nb_zax_max) 110 110 !- … … 112 112 !- 113 113 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 114 & n ame_length,nbopp114 & nbopp 115 115 CHARACTER(LEN=20),DIMENSION(nb_files_max,nb_var_max),SAVE :: & 116 116 & name,unit_name … … 149 149 !- 150 150 INTEGER,DIMENSION(nb_files_max,nb_var_max),SAVE :: & 151 & tdimid,tax_last ,tax_name_length151 & tdimid,tax_last 152 152 CHARACTER(LEN=40),DIMENSION(nb_files_max,nb_var_max),SAVE :: & 153 153 & tax_name … … 824 824 ncid = ncdf_ids(pfileid) 825 825 !- 826 IF ( SIZE(plon_bounds,DIM=1) == pim ) THEN827 nbbounds = SIZE(plon_bounds, 826 IF ( SIZE(plon_bounds,DIM=1) == pim ) THEN 827 nbbounds = SIZE(plon_bounds,DIM=2) 828 828 transp = .TRUE. 829 ELSEIF ( SIZE(plon_bounds, 830 nbbounds = SIZE(plon_bounds, 829 ELSEIF ( SIZE(plon_bounds,DIM=2) == pim ) THEN 830 nbbounds = SIZE(plon_bounds,DIM=1) 831 831 transp = .FALSE. 832 832 ELSE … … 980 980 !- 981 981 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 984 983 CHARACTER(LEN=70) :: str70, str71, str72 985 984 CHARACTER(LEN=80) :: str80 … … 1029 1028 str20 = pzaxname 1030 1029 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) 1034 1031 ELSE 1035 1032 pos = 0 … … 1038 1035 IF ( pos > 0) THEN 1039 1036 str70 = "Vertical axis already exists" 1040 WRITE(str71,'("Check variable ", a," in file",I3)') str20,pfileid1037 WRITE(str71,'("Check variable ",A," in file",I3)') str20,pfileid 1041 1038 str72 = "Can also be a wrong file ID in another declaration" 1042 1039 CALL ipslerr (3,"histvert", str70, str71, str72) … … 1085 1082 zax_size(pfileid, iv) = pzsize 1086 1083 zax_name(pfileid, iv) = pzaxname 1087 zax_name_length(pfileid, iv) = LEN_TRIM(pzaxname)1088 1084 zax_ids(pfileid, iv) = zaxid_tmp 1089 1085 pzaxid = iv … … 1155 1151 CHARACTER(LEN=70) :: str70, str71, str72 1156 1152 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 1159 1154 CHARACTER(LEN=40) :: str40, tab_str40(nb_var_max) 1160 INTEGER :: tab_str40_length(nb_var_max)1161 1155 CHARACTER(LEN=10) :: str10 1162 1156 CHARACTER(LEN=80) :: tmp_str80 … … 1188 1182 str20 = pvarname 1189 1183 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) 1193 1185 ELSE 1194 1186 pos = 0 … … 1203 1195 !- 1204 1196 name(pfileid,iv) = pvarname 1205 name_length(pfileid,iv) = LEN_TRIM(name(pfileid,iv))1206 1197 title(pfileid,iv) = ptitle 1207 1198 unit_name(pfileid,iv) = punit … … 1306 1297 & "to the size of the chosen vertical axis" 1307 1298 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)') & 1309 1300 & TRIM(str20), zax_size(pfileid,pzid) 1310 1301 CALL ipslerr (3,"histdef", str70, str71, str72) … … 1476 1467 ENDIF 1477 1468 !- 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) 1484 1471 !- 1485 1472 ! No time axis for once, l_max, l_min or never operation … … 1492 1479 nb_tax(pfileid) = nb_tax(pfileid)+1 1493 1480 tax_name(pfileid,nb_tax(pfileid)) = str40 1494 tax_name_length(pfileid, nb_tax(pfileid)) = LEN_TRIM(str40)1495 1481 tax_last(pfileid,nb_tax(pfileid)) = 0 1496 1482 var_axid(pfileid,iv) = nb_tax(pfileid) … … 2471 2457 INTEGER,SAVE :: varseq_err(nb_files_max) = 0 2472 2458 INTEGER :: ib, nb, sp, nx, pos 2473 CHARACTER(LEN=20),DIMENSION(nb_var_max) :: tab_str202474 2459 CHARACTER(LEN=20) :: str20 2475 2460 CHARACTER(LEN=70) :: str70 2476 INTEGER :: tab_str20_length(nb_var_max)2477 2461 !- 2478 2462 LOGICAL :: check = .FALSE. … … 2500 2484 !- 2501 2485 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) 2506 2487 !- 2507 2488 IF (pos > 0) THEN … … 2565 2546 pvid = varseq(pfid, nx) 2566 2547 !- 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 2569 2549 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) 2573 2551 IF (pos > 0) THEN 2574 2552 pvid = pos -
IOIPSL/trunk/src/restcom.f90
r11 r122 126 126 & varname_in,varname_out 127 127 INTEGER,DIMENSION(max_file,max_var),SAVE :: & 128 & varname_in_length,varname_out_length, &129 128 & varid_in,varid_out,varnbdim_in,varatt_in 130 129 INTEGER,DIMENSION(max_file,max_var,max_dim),SAVE :: & … … 357 356 netcdf_id(nbfiles,2) = netcdf_id(nbfiles,1) 358 357 varname_out(nbfiles,:) = varname_in(nbfiles,:) 359 varname_out_length(nbfiles,:) = varname_in_length(nbfiles,:)360 358 nbvar_out(nbfiles) = nbvar_in(nbfiles) 361 359 tind_varid_out(nbfiles) = tind_varid_in(nbfiles) … … 550 548 ENDDO 551 549 !--- 552 varname_in_length(fid,iv) = LEN_TRIM(varname_in(fid,iv))553 !---554 550 !-- 2.1 Read the units of the variable 555 551 !--- … … 1487 1483 ncfid = netcdf_id(fid,1) 1488 1484 !- 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) 1492 1486 !- 1493 1487 ! 1.0 If the variable is not present then ERROR or filled up … … 1513 1507 vnb = nbvar_in(fid) 1514 1508 varname_in(fid,vnb) = vname_q 1515 varname_in_length(fid,vnb) = LEN_TRIM(vname_q)1516 1509 touched_in(fid,vnb) = .TRUE. 1517 1510 !----- … … 2118 2111 IF (check) WRITE(*,*) 'RESTPUT 1.0 : ',TRIM(vname_q) 2119 2112 !- 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) 2123 2114 !- 2124 2115 IF (check) THEN … … 2265 2256 nbvar_out(fid) = nbvar_out(fid)+1 2266 2257 varname_out(fid,nbvar_out(fid)) = varname 2267 varname_out_length(fid,nbvar_out(fid)) = LEN_TRIM(varname)2268 2258 !- 2269 2259 ! 0.0 Put the file in define mode if needed … … 2441 2431 !--------------------------------------------------------------------- 2442 2432 ! 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) 2446 2434 !- 2447 2435 IF (vnb > 0) THEN -
IOIPSL/trunk/src/stringop.f90
r19 r122 76 76 END FUNCTION findpos 77 77 !=== 78 SUBROUTINE find_str ( nb_str,str_tab,str_len_tab,str,pos)78 SUBROUTINE find_str (str_tab,str,pos) 79 79 !--------------------------------------------------------------------- 80 80 !- This subroutine looks for a string in a table 81 81 !--------------------------------------------------------------------- 82 82 !- 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 87 85 !- 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 99 95 !--------------------------------------------------------------------- 100 96 pos = -1 101 il = LEN_TRIM(str)97 nb_str=SIZE(str_tab) 102 98 IF ( nb_str > 0 ) THEN 103 99 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 106 101 pos = i 107 102 EXIT
Note: See TracChangeset
for help on using the changeset viewer.
