Changeset 3188 for IOIPSL/trunk


Ignore:
Timestamp:
03/24/17 14:36:20 (5 years ago)
Author:
jgipsl
Message:

Adapted restcom to handle more dimensions. Added _FillValue attribute. See ticket #110

File:
1 edited

Legend:

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

    r2020 r3188  
    88USE netcdf 
    99!- 
     10USE defprec 
    1011USE errioipsl, ONLY : ipslerr,ipsldbg, ipslout 
    1112USE stringop 
     
    2627  MODULE PROCEDURE & 
    2728 &  restput_r3d, restput_r2d, restput_r1d, & 
    28  &  restput_opp_r2d, restput_opp_r1d 
     29 &  restput_opp_r2d, restput_opp_r1d, restput_opp_r3d, & 
     30 &  restput_opp_r4d, restput_opp_r5d 
    2931END INTERFACE 
    3032!- 
     
    3234  MODULE PROCEDURE & 
    3335 &  restget_r3d,restget_r2d,restget_r1d, & 
    34  &  restget_opp_r2d,restget_opp_r1d 
     36 &  restget_opp_r2d, restget_opp_r1d, restget_opp_r3d, & 
     37 &  restget_opp_r4d, restget_opp_r5d 
    3538END INTERFACE 
    3639!- 
     
    4043!- 
    4144  INTEGER,PARAMETER :: & 
    42  &  max_var=500, max_file=50, max_dim=NF90_MAX_VAR_DIMS 
     45 &  max_var=500, max_file=50, MAX_DIM=NF90_MAX_VAR_DIMS, RESTART_MAX_DIMS=7 ! 
     46! RESTART_MAX_DIMS = Max dimensions in 1 variable IOIPSL can manage for restart files (> 3) 
    4347!- 
    4448  CHARACTER(LEN=9),SAVE :: calend_str='unknown' 
     
    8892!   ?ax_nb(if) 
    8993!- 
    90   INTEGER,DIMENSION(max_file,max_dim,2),SAVE :: & 
    91  &  xax_infs,yax_infs,zax_infs 
    92   INTEGER,DIMENSION(max_file),SAVE :: & 
    93  &  xax_nb=0,yax_nb=0,zax_nb=0 
     94  INTEGER,DIMENSION(max_file,RESTART_MAX_DIMS,max_dim,2),SAVE :: & 
     95 &  ax_infs!,yax_infs,zax_infs,wax_infs 
     96  INTEGER,DIMENSION(max_file,RESTART_MAX_DIMS),SAVE :: & 
     97 &  ax_nb=0! ,yax_nb=0,zax_nb=0,wax_nb=0 
     98!- 
     99! Dimensions names, must be equal to RESTART_MAX_DIMS: 
     100! - DO not repeat any char 
     101! - ONLY 1 single char per dimension 
     102  CHARACTER, DIMENSION(RESTART_MAX_DIMS), PARAMETER :: RESTART_DIMS_NAMES = & 
     103     (/ 'x','y','z','l','m','n', 'o'/) 
     104 
     105!- Dimensions constants for basic dimensions 
     106  INTEGER, PARAMETER :: RESTART_DIM_X = 1 
     107  INTEGER, PARAMETER :: RESTART_DIM_Y = 2 
     108  INTEGER, PARAMETER :: RESTART_DIM_Z = 3 
    94109!- 
    95110! Description of the time axes in the input and output files 
     
    158173SUBROUTINE restini & 
    159174 & (fnamein,iim,jjm,lon,lat,llm,lev, & 
    160  &  fnameout,itau,date0,dt,fid,owrite_time_in,domain_id) 
     175 &  fnameout,itau,date0,dt,fid,owrite_time_in,domain_id ) 
    161176!--------------------------------------------------------------------- 
    162177!- This subroutine sets up all the restart process. 
     
    203218!-                  overwrite the time in the restart file 
    204219!- domain_id      : Domain identifier 
     220!- 
    205221!--------------------------------------------------------------------- 
    206222  IMPLICIT NONE 
     
    242258 &   'and recompiling ioipsl.') 
    243259  ENDIF 
    244 !- 
    245 ! 0.1 Define the open flags 
    246260!- 
    247261  l_fi = (TRIM(fnamein)  /= 'NONE') 
     
    407421! then we open it in write mode 
    408422!- 
    409   IF (l_rw) THEN; id = NF90_WRITE; ELSE; id = NF90_NOWRITE; ENDIF 
     423  IF (l_rw) THEN; id = IOR(NF90_WRITE,NF90_NETCDF4); ELSE; id = IOR(NF90_NOWRITE,NF90_NETCDF4); ENDIF 
    410424  iret = NF90_OPEN(fname,id,ncfid) 
    411425  IF (iret /= NF90_NOERR) THEN 
     
    440454      WRITE (*,*) "restopenin 0.0 dimname",id,TRIM(dimname(id)) 
    441455    ENDIF 
    442     IF      (TRIM(dimname(id)) == 'x') THEN 
     456    IF      (TRIM(dimname(id)) == RESTART_DIMS_NAMES(RESTART_DIM_X)) THEN 
    443457      iread = dimlen(id) 
    444458      IF (l_dbg) WRITE (*,*) "iread",iread 
    445     ELSE IF (TRIM(dimname(id)) == 'y') THEN 
     459    ELSE IF (TRIM(dimname(id)) == RESTART_DIMS_NAMES(RESTART_DIM_Y)) THEN 
    446460      jread = dimlen(id) 
    447461      IF (l_dbg) WRITE (*,*) "jread",jread 
    448     ELSE IF (TRIM(dimname(id)) == 'z') THEN 
     462    ELSE IF (TRIM(dimname(id)) == RESTART_DIMS_NAMES(RESTART_DIM_Z)) THEN 
    449463      lread = dimlen(id) 
    450464      IF (l_dbg) WRITE (*,*) "lread",lread 
     
    468482      ENDIF 
    469483!----- 
    470       xax_nb(fid) = 0 
    471       yax_nb(fid) = 0 
    472       zax_nb(fid) = 0 
     484      ax_nb(fid,:) = 0 
    473485!----- 
    474486      DO id=1,nb_dim 
    475         IF      (dimname(id)(1:1) == 'x') THEN 
    476           xax_nb(fid) = xax_nb(fid)+1 
    477           xax_infs(fid,xax_nb(fid),1) = dimlen(id) 
    478           xax_infs(fid,xax_nb(fid),2) = id 
    479         ELSE IF (dimname(id)(1:1) == 'y') THEN 
    480           yax_nb(fid) = yax_nb(fid)+1 
    481           yax_infs(fid,yax_nb(fid),1) = dimlen(id) 
    482           yax_infs(fid,yax_nb(fid),2) = id 
    483         ELSE IF (dimname(id)(1:1) == 'z') THEN 
    484           zax_nb(fid) = zax_nb(fid)+1 
    485           zax_infs(fid,zax_nb(fid),1) = dimlen(id) 
    486           zax_infs(fid,zax_nb(fid),2) = id 
     487        ! Order is important 
     488        IF      (dimname(id)(1:1) == RESTART_DIMS_NAMES(id)) THEN 
     489          ax_nb(fid,id) = ax_nb(fid,id)+1 
     490          ax_infs(fid,id,ax_nb(fid,id),1) = dimlen(id) 
     491          ax_infs(fid,id,ax_nb(fid,id),2) = id 
    487492        ENDIF 
     493      ENDDO 
     494!----- 
     495!---  Initialize non basic dimensions 
     496!----- 
     497      DO id=4,RESTART_MAX_DIMS 
     498        ax_nb(fid,id) = 1 
    488499      ENDDO 
    489500    ENDIF 
     
    832843  CHARACTER(LEN=30) :: timenow 
    833844  LOGICAL :: l_dbg 
     845  INTEGER :: cmode, id 
    834846!--------------------------------------------------------------------- 
    835847  CALL ipsldbg (old_status=l_dbg) 
     
    840852!- we will not even call restopenout 
    841853!- 
    842   iret = NF90_CREATE(fname,cmode=or(NF90_NOCLOBBER,NF90_64BIT_OFFSET),ncid=ncfid) 
     854  iret = NF90_CREATE(fname,cmode=or(NF90_NOCLOBBER,NF90_NETCDF4),ncid=ncfid) 
    843855  IF (iret == -35) THEN 
    844856    CALL ipslerr (3,'restopenout',& 
     
    847859      & ' generate the new one with another name') 
    848860  ENDIF 
    849 !- 
    850   iret = NF90_DEF_DIM(ncfid,'x',iim,x_id) 
    851   xax_nb(fid) = xax_nb(fid)+1 
    852   xax_infs(fid,xax_nb(fid),1) = iim 
    853   xax_infs(fid,xax_nb(fid),2) = x_id 
    854 !- 
    855   iret = NF90_DEF_DIM(ncfid,'y',jjm,y_id) 
    856   yax_nb(fid)  = yax_nb(fid)+1 
    857   yax_infs(fid,yax_nb(fid),1) = jjm 
    858   yax_infs(fid,yax_nb(fid),2) = y_id 
    859 !- 
    860   iret = NF90_DEF_DIM(ncfid,'z',llm,z_id) 
    861   zax_nb(fid) = zax_nb(fid)+1 
    862   zax_infs(fid,zax_nb(fid),1) = llm 
    863   zax_infs(fid,zax_nb(fid),2) = z_id 
     861!- Define basic dimensions (x, y, z) 
     862  iret = NF90_DEF_DIM(ncfid,RESTART_DIMS_NAMES(RESTART_DIM_X),iim,x_id) 
     863  ax_nb(fid,RESTART_DIM_X) = ax_nb(fid, RESTART_DIM_X)+1 
     864  ax_infs(fid,RESTART_DIM_X, ax_nb(fid, RESTART_DIM_X),1) = iim 
     865  ax_infs(fid,RESTART_DIM_X, ax_nb(fid, RESTART_DIM_X),2) = x_id 
     866!- 
     867  iret = NF90_DEF_DIM(ncfid,RESTART_DIMS_NAMES(RESTART_DIM_Y),jjm,y_id) 
     868  ax_nb(fid,RESTART_DIM_Y) = ax_nb(fid, RESTART_DIM_Y)+1 
     869  ax_infs(fid,RESTART_DIM_Y, ax_nb(fid, RESTART_DIM_Y),1) = jjm 
     870  ax_infs(fid,RESTART_DIM_Y, ax_nb(fid, RESTART_DIM_Y),2) = y_id 
     871!- 
     872  iret = NF90_DEF_DIM(ncfid,RESTART_DIMS_NAMES(RESTART_DIM_Z),llm,z_id) 
     873  ax_nb(fid,RESTART_DIM_Z) = ax_nb(fid, RESTART_DIM_Z)+1 
     874  ax_infs(fid,RESTART_DIM_Z, ax_nb(fid, RESTART_DIM_Z),1) = llm 
     875  ax_infs(fid,RESTART_DIM_Z, ax_nb(fid, RESTART_DIM_Z),2) = z_id 
     876!- 
     877!  Initialize non basic dimensions 
     878!- 
     879  DO id=4,RESTART_MAX_DIMS 
     880    ax_nb(fid,id) = 1 
     881  ENDDO 
    864882!- 
    865883  iret = NF90_DEF_DIM(ncfid,'time',NF90_UNLIMITED,tdimid_out(fid)) 
     
    10141032  CHARACTER(LEN=7) :: topp 
    10151033  LOGICAL :: l_dbg 
     1034  INTEGER :: list_dims(2) ! x and y 
    10161035!--------------------------------------------------------------------- 
    10171036  CALL ipsldbg (old_status=l_dbg) 
     
    10211040  req_sz = 1 
    10221041  IF (nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN 
    1023     IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) 
    1024     IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) 
    1025     IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1) 
     1042    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1043    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
     1044    IF (ax_infs(fid,RESTART_DIM_Z,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Z,1,1) 
    10261045  ELSE 
    10271046    CALL ipslerr (3,'resget_opp_r1d', & 
     
    10391058! 2.0 Here we get the variable from the restart file 
    10401059!- 
     1060  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1) /) 
     1061!- 
    10411062  CALL restget_real & 
    1042     (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & 
    1043      zax_infs(fid,1,1),itau,def_beha,buff_tmp2) 
     1063    (fid,vname_q,list_dims,itau,def_beha,buff_tmp2) 
    10441064!- 
    10451065! 4.0 Transfer the buffer obtained from the restart file 
     
    10831103  CHARACTER(LEN=7) :: topp 
    10841104  LOGICAL :: l_dbg 
     1105  INTEGER :: list_dims(3) 
    10851106!--------------------------------------------------------------------- 
    10861107  CALL ipsldbg (old_status=l_dbg) 
     
    10901111  req_sz = 1 
    10911112  IF (nbindex == iim  .AND. llm <= 1) THEN 
    1092     IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) 
    1093     IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) 
     1113    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1114    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
    10941115  ELSE 
    10951116    CALL ipslerr (3,'resget_opp_r2d', & 
     
    11131134! 2.0 Here we get the full variable from the restart file 
    11141135!- 
     1136  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1), jjm /) 
     1137!- 
    11151138  CALL restget_real & 
    1116  & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & 
    1117  &  jjm,itau,def_beha,buff_tmp2) 
     1139 & (fid,vname_q,list_dims,itau,def_beha,buff_tmp2) 
    11181140!- 
    11191141! 4.0 Transfer the buffer obtained from the restart file 
     
    11391161END SUBROUTINE restget_opp_r2d 
    11401162!=== 
     1163SUBROUTINE restget_opp_r3d & 
     1164 & (fid,vname_q,iim,jjm,llm,itau,def_beha, & 
     1165 &  var,MY_OPERATOR,nbindex,ijndex) 
     1166!--------------------------------------------------------------------- 
     1167!- This subroutine serves as an interface to restget_real 
     1168!- 
     1169!- Should work as restput_opp_r2d but the other way around ! 
     1170!--------------------------------------------------------------------- 
     1171  IMPLICIT NONE 
     1172!- 
     1173  INTEGER :: fid 
     1174  CHARACTER(LEN=*) :: vname_q 
     1175  INTEGER :: iim,jjm,llm,itau 
     1176  LOGICAL def_beha 
     1177  REAL :: var(:,:,:) 
     1178  CHARACTER(LEN=*) :: MY_OPERATOR 
     1179  INTEGER :: nbindex,ijndex(nbindex) 
     1180!- 
     1181  INTEGER :: ll,jj,req_sz,ist,var_sz,siz1 
     1182  REAL :: scal 
     1183  CHARACTER(LEN=7) :: topp 
     1184  LOGICAL :: l_dbg 
     1185  INTEGER :: list_dims(4) 
     1186!--------------------------------------------------------------------- 
     1187  CALL ipsldbg (old_status=l_dbg) 
     1188!- 
     1189! 0.0 What size should be the data in the file 
     1190!- 
     1191  req_sz = 1 
     1192  IF (nbindex == iim) THEN 
     1193    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1194    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
     1195  ELSE 
     1196    CALL ipslerr (3,'resget_opp_r3d', & 
     1197      'Unable to performe an operation on this variable as it has', & 
     1198      'a second and third dimension',vname_q) 
     1199  ENDIF 
     1200!- 
     1201  IF (jjm < 1) THEN 
     1202    CALL ipslerr (3,'resget_opp_r3d', & 
     1203      'Please specify a second dimension which is the', & 
     1204      'layer on which the operations are performed',vname_q) 
     1205  ENDIF 
     1206!- 
     1207  IF (llm < 1) THEN 
     1208    CALL ipslerr (3,'resget_opp_r3d', & 
     1209      'Please specify a third dimension which is the', & 
     1210      'layer on which the operations are performed',vname_q) 
     1211  ENDIF 
     1212!- 
     1213! 1.0 Allocate the temporary buffer we need 
     1214!     to put the variable in right dimension 
     1215!- 
     1216  siz1 = SIZE(var,1) 
     1217  CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r3d') 
     1218  CALL rest_alloc (2,req_sz*jjm*llm,l_dbg,'restget_opp_r3d') 
     1219!- 
     1220! 2.0 Here we get the full variable from the restart file 
     1221!- 
     1222  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1), jjm, llm /) 
     1223!- 
     1224  CALL restget_real & 
     1225 & (fid,vname_q,list_dims,itau,def_beha,buff_tmp2) 
     1226!- 
     1227! 4.0 Transfer the buffer obtained from the restart file 
     1228!     into the variable the model expects 
     1229!- 
     1230  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) 
     1231!- 
     1232  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN 
     1233    scal = missing_val 
     1234    var_sz = siz1 
     1235    DO ll = 1, llm 
     1236      DO jj = 1,jjm 
     1237          ist = (((ll-1)*jjm) + (jj-1))*req_sz+1 
     1238          CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz-1), & 
     1239 &           missing_val,nbindex,ijndex,scal,var_sz,buff_tmp1) 
     1240          var(:,jj,ll) = buff_tmp1(1:siz1) 
     1241      ENDDO 
     1242    ENDDO 
     1243  ELSE 
     1244    CALL ipslerr (3,'resget_opp_r3d', & 
     1245      'The operation you wish to do on the variable for the ',& 
     1246      'restart file is not allowed.',topp) 
     1247  ENDIF 
     1248!----------------------------- 
     1249END SUBROUTINE restget_opp_r3d 
     1250!=== 
     1251SUBROUTINE restget_opp_r4d & 
     1252 & (fid,vname_q,iim,jjm,llm,mmm,itau,def_beha, & 
     1253 &  var,MY_OPERATOR,nbindex,ijndex) 
     1254!--------------------------------------------------------------------- 
     1255!- This subroutine serves as an interface to restget_real 
     1256!- 
     1257!- Should work as restput_opp_r2d but the other way around ! 
     1258!--------------------------------------------------------------------- 
     1259  IMPLICIT NONE 
     1260!- 
     1261  INTEGER :: fid 
     1262  CHARACTER(LEN=*) :: vname_q 
     1263  INTEGER :: iim,jjm,llm,mmm,itau 
     1264  LOGICAL def_beha 
     1265  REAL :: var(:,:,:,:) 
     1266  CHARACTER(LEN=*) :: MY_OPERATOR 
     1267  INTEGER :: nbindex,ijndex(nbindex) 
     1268!- 
     1269  INTEGER :: mm,ll,jj,req_sz,ist,var_sz,siz1 
     1270  REAL :: scal 
     1271  CHARACTER(LEN=7) :: topp 
     1272  LOGICAL :: l_dbg 
     1273  INTEGER :: list_dims(5) 
     1274!--------------------------------------------------------------------- 
     1275  CALL ipsldbg (old_status=l_dbg) 
     1276!- 
     1277! 0.0 What size should be the data in the file 
     1278!- 
     1279  req_sz = 1 
     1280  IF (nbindex == iim) THEN 
     1281    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1282    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
     1283  ELSE 
     1284    CALL ipslerr (3,'restget_opp_r4d', & 
     1285      'Unable to performe an operation on this variable as it has', & 
     1286      'a second and third dimension',vname_q) 
     1287  ENDIF 
     1288!- 
     1289! 1.0 Allocate the temporary buffer we need 
     1290!     to put the variable in right dimension 
     1291!- 
     1292  siz1 = SIZE(var,1) 
     1293  CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r4d') 
     1294  CALL rest_alloc (2,req_sz*jjm*llm*mmm,l_dbg,'restget_opp_r4d') 
     1295!- 
     1296! 2.0 Here we get the full variable from the restart file 
     1297!- 
     1298  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1), jjm, llm, mmm /) 
     1299!- 
     1300  CALL restget_real & 
     1301 & (fid,vname_q,list_dims,itau,def_beha,buff_tmp2) 
     1302!- 
     1303! 4.0 Transfer the buffer obtained from the restart file 
     1304!     into the variable the model expects 
     1305!- 
     1306  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) 
     1307!- 
     1308  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN 
     1309    scal = missing_val 
     1310    var_sz = siz1 
     1311    DO mm = 1, mmm 
     1312      DO ll = 1, llm 
     1313        DO jj = 1,jjm 
     1314            ist = ((((mm-1)*llm + (ll-1))*jjm) + (jj-1))*req_sz+1 
     1315            CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz-1), & 
     1316 &             missing_val,nbindex,ijndex,scal,var_sz,buff_tmp1) 
     1317            var(:,jj,ll,mm) = buff_tmp1(1:siz1) 
     1318        ENDDO 
     1319      ENDDO 
     1320    ENDDO 
     1321  ELSE 
     1322    CALL ipslerr (3,'restget_opp_r4d', & 
     1323      'The operation you wish to do on the variable for the ',& 
     1324      'restart file is not allowed.',topp) 
     1325  ENDIF 
     1326!----------------------------- 
     1327END SUBROUTINE restget_opp_r4d 
     1328!=== 
     1329SUBROUTINE restget_opp_r5d & 
     1330 & (fid,vname_q,iim,jjm,llm,mmm,nnm,itau,def_beha, & 
     1331 &  var,MY_OPERATOR,nbindex,ijndex) 
     1332!--------------------------------------------------------------------- 
     1333!- This subroutine serves as an interface to restget_real 
     1334!- 
     1335!- Should work as restput_opp_r2d but the other way around ! 
     1336!--------------------------------------------------------------------- 
     1337  IMPLICIT NONE 
     1338!- 
     1339  INTEGER :: fid 
     1340  CHARACTER(LEN=*) :: vname_q 
     1341  INTEGER :: iim,jjm,llm,mmm,nnm,itau 
     1342  LOGICAL def_beha 
     1343  REAL :: var(:,:,:,:,:) 
     1344  CHARACTER(LEN=*) :: MY_OPERATOR 
     1345  INTEGER :: nbindex,ijndex(nbindex) 
     1346!- 
     1347  INTEGER :: mm,ll,jj,nn,req_sz,ist,var_sz,siz1 
     1348  REAL :: scal 
     1349  CHARACTER(LEN=7) :: topp 
     1350  LOGICAL :: l_dbg 
     1351  INTEGER :: list_dims(6) 
     1352!--------------------------------------------------------------------- 
     1353  CALL ipsldbg (old_status=l_dbg) 
     1354!- 
     1355! 0.0 What size should be the data in the file 
     1356!- 
     1357  req_sz = 1 
     1358  IF (nbindex == iim) THEN 
     1359    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1360    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
     1361  ELSE 
     1362    CALL ipslerr (3,'restget_opp_r5d', & 
     1363      'Unable to performe an operation on this variable as it has', & 
     1364      'a second and third dimension',vname_q) 
     1365  ENDIF 
     1366!- 
     1367! 1.0 Allocate the temporary buffer we need 
     1368!     to put the variable in right dimension 
     1369!- 
     1370  siz1 = SIZE(var,1) 
     1371  CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r5d') 
     1372  CALL rest_alloc (2,req_sz*jjm*llm*mmm*nnm,l_dbg,'restget_opp_r5d') 
     1373!- 
     1374! 2.0 Here we get the full variable from the restart file 
     1375!- 
     1376  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1), jjm, llm, mmm, nnm /) 
     1377!- 
     1378  CALL restget_real & 
     1379 & (fid,vname_q,list_dims,itau,def_beha,buff_tmp2) 
     1380!- 
     1381! 4.0 Transfer the buffer obtained from the restart file 
     1382!     into the variable the model expects 
     1383!- 
     1384  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) 
     1385!- 
     1386  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN 
     1387    scal = missing_val 
     1388    var_sz = siz1 
     1389    DO nn=1, nnm 
     1390      DO mm = 1, mmm 
     1391        DO ll = 1, llm 
     1392          DO jj = 1,jjm 
     1393              ist = (((((nn-1)*mmm) + (mm-1)*llm + (ll-1))*jjm) + (jj-1))*req_sz+1 
     1394              CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz-1), & 
     1395 &               missing_val,nbindex,ijndex,scal,var_sz,buff_tmp1) 
     1396              var(:,jj,ll,mm,nn) = buff_tmp1(1:siz1) 
     1397          ENDDO 
     1398        ENDDO 
     1399      ENDDO 
     1400    ENDDO 
     1401  ELSE 
     1402    CALL ipslerr (3,'restget_opp_r5d', & 
     1403      'The operation you wish to do on the variable for the ',& 
     1404      'restart file is not allowed.',topp) 
     1405  ENDIF 
     1406!----------------------------- 
     1407END SUBROUTINE restget_opp_r5d 
     1408!=== 
    11411409SUBROUTINE restget_r1d & 
    11421410 & (fid,vname_q,iim,jjm,llm,itau,def_beha,var) 
     
    11551423  CHARACTER(LEN=70) :: str,str2 
    11561424  LOGICAL :: l_dbg 
     1425  INTEGER :: list_dims(2) 
    11571426!--------------------------------------------------------------------- 
    11581427  CALL ipsldbg (old_status=l_dbg) 
     
    11881457  ENDIF 
    11891458!- 
     1459  list_dims = (/ iim,jjm /) 
     1460!- 
    11901461  CALL restget_real & 
    1191  & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) 
     1462 & (fid,vname_q,list_dims,itau,def_beha,buff_tmp1) 
    11921463!- 
    11931464! 4.0 Transfer the buffer obtained from the restart file 
     
    12181489  CHARACTER(LEN=70) :: str,str2 
    12191490  LOGICAL :: l_dbg 
     1491  INTEGER :: list_dims(2) 
    12201492!--------------------------------------------------------------------- 
    12211493  CALL ipsldbg (old_status=l_dbg) 
     
    12531525  ENDIF 
    12541526!- 
     1527  list_dims = (/ iim,jjm /) 
     1528!- 
    12551529  CALL restget_real & 
    1256  & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) 
     1530 & (fid,vname_q,list_dims,itau,def_beha,buff_tmp1) 
    12571531!- 
    12581532! 4.0 Transfer the buffer obtained from the restart file 
     
    12851559  CHARACTER(LEN=70) :: str,str2 
    12861560  LOGICAL :: l_dbg 
     1561  INTEGER :: list_dims(3) 
    12871562!--------------------------------------------------------------------- 
    12881563  CALL ipsldbg (old_status=l_dbg) 
     
    13211596  ENDIF 
    13221597!- 
     1598  list_dims = (/ iim,jjm,llm /) 
     1599!- 
    13231600  CALL restget_real & 
    1324     (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) 
     1601    (fid,vname_q,list_dims,itau,def_beha,buff_tmp1) 
    13251602!- 
    13261603! 4.0 Transfer the buffer obtained from the restart file 
     
    13401617!=== 
    13411618SUBROUTINE restget_real & 
    1342   (fid,vname_q,iim,jjm,llm,itau,def_beha,var) 
     1619  (fid,vname_q,list_dims,itau,def_beha,var) 
    13431620!--------------------------------------------------------------------- 
    13441621!- This subroutine is for getting a variable from the restart file. 
     
    13681645  INTEGER :: fid 
    13691646  CHARACTER(LEN=*) :: vname_q 
    1370   INTEGER :: iim,jjm,llm,itau 
     1647  INTEGER,DIMENSION(:),INTENT(in) :: list_dims 
     1648  INTEGER :: itau 
    13711649  LOGICAL :: def_beha 
    13721650  REAL :: var(:) 
    13731651!- 
    1374   INTEGER :: vid,vnb,ncfid,iret,index,it,ndim,ia 
     1652  INTEGER :: vid,vnb,ncfid,iret,index,it,ndim,ia,itedim 
    13751653  CHARACTER(LEN=70) str,str2 
    13761654  CHARACTER(LEN=80) attname 
    1377   INTEGER,DIMENSION(4) :: corner,edge 
     1655  INTEGER,DIMENSION(RESTART_MAX_DIMS) :: corner,edge 
    13781656  LOGICAL :: l_dbg 
    13791657!--------------------------------------------------------------------- 
    13801658  CALL ipsldbg (old_status=l_dbg) 
    13811659!--------------------------------------------------------------------- 
    1382   IF (l_dbg) WRITE(ipslout,*) 'RESTGET 0.0 : ',netcdf_name(fid,2),vname_q,iim,jjm,llm,itau,def_beha 
     1660  IF (l_dbg) WRITE(ipslout,*) 'RESTGET 0.0 : ',netcdf_name(fid,2),vname_q,list_dims,itau,def_beha 
    13831661!- 
    13841662  ncfid = netcdf_id(fid,1) 
     
    13901668!- 
    13911669  IF (l_dbg) WRITE(ipslout,*) 'RESTGET 1.0 : ',vnb 
     1670!- 
     1671  IF (ANY(list_dims < 1)) THEN 
     1672      CALL ipslerr (3,'restget', & 
     1673 &      'All values in list_dims must be positive','','') 
     1674  ENDIF 
     1675  IF (SIZE(list_dims, 1) > RESTART_MAX_DIMS) THEN 
     1676      CALL ipslerr (3,'restget', & 
     1677 &      'Limit reached for dimensions','Please increase RESTART_MAX_DIMS to allow', & 
     1678        ' more dimensions in single variable ') 
     1679  ENDIF 
     1680  IF (SIZE(list_dims, 1) == 0) THEN 
     1681      CALL ipslerr (3,'restget', & 
     1682 &      'No dimension is given','Make sure to pass a valid list_dims', & 
     1683        ' ') 
     1684  ENDIF 
    13921685!- 
    13931686  IF (vnb < 0) THEN 
     
    14121705      touched_in(fid,vnb) = .TRUE. 
    14131706!----- 
    1414       CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.) 
     1707      CALL restdefv (fid,vname_q,list_dims,.TRUE.) 
    14151708      IF (l_dbg) WRITE(ipslout,*) 'RESTGET 1.1 : ',vnb 
    14161709!----- 
     
    14571750    str='Incorrect dimension for '//TRIM(vname_q) 
    14581751    ndim = 0 
    1459     IF (iim > 0) THEN 
    1460       ndim = ndim+1 
    1461       IF (vardims_in(fid,vnb,ndim) == iim) THEN 
    1462         corner(ndim) = 1 
    1463         edge(ndim) = iim 
    1464       ELSE 
    1465         WRITE (str2,'("Incompatibility for iim : ",I6,I6)') & 
    1466              iim,vardims_in(fid,vnb,ndim) 
    1467         CALL ipslerr (3,'restget',str,str2,' ') 
    1468       ENDIF 
    1469     ENDIF 
    1470 !--- 
    1471     IF (jjm > 0) THEN 
    1472       ndim = ndim+1 
    1473       IF (vardims_in(fid,vnb,ndim) == jjm) THEN 
    1474         corner(ndim) = 1 
    1475         edge(ndim) = jjm 
    1476       ELSE 
    1477         WRITE (str2,'("Incompatibility for jjm : ",I6,I6)') & 
    1478              jjm,vardims_in(fid,vnb,ndim) 
    1479         CALL ipslerr (3,'restget',str,str2,' ') 
    1480       ENDIF 
    1481     ENDIF 
    1482 !--- 
    1483     IF (llm > 0) THEN 
    1484       ndim = ndim+1 
    1485       IF (vardims_in(fid,vnb,ndim) == llm) THEN 
    1486         corner(ndim) = 1 
    1487         edge(ndim) = llm 
    1488       ELSE 
    1489         WRITE (str2,'("Incompatibility for llm : ",I6,I6)') & 
    1490              llm,vardims_in(fid,vnb,ndim) 
    1491         CALL ipslerr (3,'restget',str,str2,' ') 
    1492       ENDIF 
    1493     ENDIF 
     1752!-- 
     1753    DO itedim=1, SIZE(list_dims,1) 
     1754        ndim = ndim+1 
     1755        IF (vardims_in(fid,vnb,ndim) == list_dims(itedim)) THEN 
     1756          corner(ndim) = 1 
     1757          edge(ndim) = list_dims(itedim) 
     1758        ELSE 
     1759          WRITE (str2,'("Incompatibility for I2 dimension : ",I6,I6,I6)') & 
     1760               itedim,list_dims(itedim),vardims_in(fid,vnb,ndim) 
     1761          CALL ipslerr (3,'restget',str,str2,' ') 
     1762        ENDIF 
     1763    ENDDO 
    14941764!--- 
    14951765!-- Time 
     
    14971767    ndim = ndim+1 
    14981768    corner(ndim) = index 
    1499 !!????? edge(ndim) = index 
    15001769    edge(ndim) = 1 
    15011770!--- 
     
    15101779 &      .AND.(netcdf_id(fid,2) > 0) ) THEN 
    15111780!----- 
    1512       CALL restdefv (fid,vname_q,iim,jjm,llm,.FALSE.) 
     1781      CALL restdefv (fid,vname_q,list_dims,.FALSE.) 
    15131782!----- 
    15141783      DO ia = 1,varatt_in(fid,vnb) 
     
    15531822  CHARACTER(LEN=7) :: topp 
    15541823  LOGICAL :: l_dbg 
     1824  INTEGER :: list_dims(2) 
    15551825!--------------------------------------------------------------------- 
    15561826  CALL ipsldbg (old_status=l_dbg) 
     
    15601830  req_sz = 1 
    15611831  IF ( nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN 
    1562     IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) 
    1563     IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) 
    1564     IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1) 
     1832    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1833    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
    15651834  ELSE 
    15661835    CALL ipslerr (3,'restput_opp_r1d', & 
     
    15941863  ENDIF 
    15951864!- 
     1865  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1) /) 
     1866!- 
    15961867  CALL restput_real & 
    1597  & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & 
    1598  &  zax_infs(fid,1,1),itau,buff_tmp2) 
     1868 & (fid,vname_q,list_dims,itau,buff_tmp2) 
    15991869!----------------------------- 
    16001870END SUBROUTINE restput_opp_r1d 
     
    16291899  CHARACTER(LEN=7) :: topp 
    16301900  LOGICAL :: l_dbg 
     1901  INTEGER :: list_dims(3) 
    16311902!--------------------------------------------------------------------- 
    16321903  CALL ipsldbg (old_status=l_dbg) 
     
    16361907  req_sz = 1 
    16371908  IF ( nbindex == iim .AND. llm <= 1) THEN 
    1638     IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) 
    1639     IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) 
     1909    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1910    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
    16401911  ELSE 
    16411912    CALL ipslerr (3,'restput_opp_r2d', & 
     
    16781949  ENDIF 
    16791950!- 
    1680   CALL restput_real & 
    1681  & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & 
    1682  &  jjm,itau,buff_tmp2) 
     1951  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1),ax_infs(fid,RESTART_DIM_Y,1,1),jjm /) 
     1952!- 
     1953  CALL restput_real (fid,vname_q, list_dims,itau,buff_tmp2) 
    16831954!----------------------------- 
    16841955END SUBROUTINE restput_opp_r2d 
     1956!=== 
     1957SUBROUTINE restput_opp_r3d & 
     1958 & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex) 
     1959!--------------------------------------------------------------------- 
     1960!- This subroutine is the interface to restput_real which allows 
     1961!- to re-index data onto the original grid of the restart file. 
     1962!- The logic we use is still fuzzy in my mind but that is probably 
     1963!- only because I have not yet though through everything. 
     1964!- 
     1965!- In the case iim = nbindex it means that the user attempts 
     1966!- to project the first dimension of the matrix back onto a 3D field 
     1967!- where jjm will be the third dimension. 
     1968!--------------------------------------------------------------------- 
     1969  IMPLICIT NONE 
     1970!- 
     1971  INTEGER :: fid 
     1972  CHARACTER(LEN=*) :: vname_q 
     1973  INTEGER :: iim,jjm,llm,itau 
     1974  REAL :: var(:,:,:) 
     1975  CHARACTER(LEN=*) :: MY_OPERATOR 
     1976  INTEGER :: nbindex,ijndex(nbindex) 
     1977!- 
     1978  INTEGER :: jj,ll,req_sz,ist,siz1 
     1979  REAL :: scal 
     1980  CHARACTER(LEN=7) :: topp 
     1981  LOGICAL :: l_dbg 
     1982  INTEGER :: list_dims(4) 
     1983!--------------------------------------------------------------------- 
     1984  CALL ipsldbg (old_status=l_dbg) 
     1985!- 
     1986! 0.0 What size should be the data in the file 
     1987!- 
     1988  req_sz = 1 
     1989  IF ( nbindex == iim) THEN 
     1990    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     1991    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
     1992  ELSE 
     1993    CALL ipslerr (3,'restput_opp_r3d', & 
     1994      'Unable to performe an operation on this variable as it has', & 
     1995      'a second and third dimension',vname_q) 
     1996  ENDIF 
     1997!- 
     1998  IF (jjm < 1 .OR. llm < 1) THEN 
     1999    CALL ipslerr (3,'restput_opp_r3d', & 
     2000      'Please specify a second dimension which is the', & 
     2001      'layer on which the operations are performed',vname_q) 
     2002  ENDIF 
     2003!- 
     2004! 1.0 Allocate the temporary buffer we need 
     2005!     to put the variable in right dimension 
     2006!- 
     2007  siz1 = SIZE(var,1) 
     2008  CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r3d') 
     2009  CALL rest_alloc (2,req_sz*jjm*llm,l_dbg,'restput_opp_r3d') 
     2010!- 
     2011! 2.0 We do the operation needed. 
     2012!     It can only be a re-indexing operation. 
     2013!     You would not want to change the values in a restart file or ? 
     2014!- 
     2015  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) 
     2016!- 
     2017  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN 
     2018    scal = missing_val 
     2019    DO ll = 1,llm 
     2020        DO jj = 1,jjm 
     2021          buff_tmp1(1:siz1) = var(:,jj,ll) 
     2022          ist = (((ll-1)*jjm) + (jj-1))*req_sz+1 
     2023          CALL mathop & 
     2024 &        (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & 
     2025 &           scal,req_sz,buff_tmp2(ist:ist+req_sz-1)) 
     2026        ENDDO 
     2027    ENDDO 
     2028  ELSE 
     2029    CALL ipslerr (3,'restput_opp_r3d', & 
     2030 &    'The operation you wish to do on the variable for the ', & 
     2031 &    'restart file is not allowed.',topp) 
     2032  ENDIF 
     2033!- 
     2034  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1),ax_infs(fid,RESTART_DIM_Y,1,1),jjm,llm /) 
     2035!- 
     2036  CALL restput_real & 
     2037 & (fid,vname_q,list_dims,itau,buff_tmp2) 
     2038!----------------------------- 
     2039END SUBROUTINE restput_opp_r3d 
     2040!=== 
     2041SUBROUTINE restput_opp_r4d & 
     2042 & (fid,vname_q,iim,jjm,llm,mmm,itau,var,MY_OPERATOR,nbindex,ijndex) 
     2043!--------------------------------------------------------------------- 
     2044!- This subroutine is the interface to restput_real which allows 
     2045!- to re-index data onto the original grid of the restart file. 
     2046!- The logic we use is still fuzzy in my mind but that is probably 
     2047!- only because I have not yet though through everything. 
     2048!- 
     2049!- In the case iim = nbindex it means that the user attempts 
     2050!- to project the first dimension of the matrix back onto a 3D field 
     2051!- where jjm will be the third dimension. 
     2052!--------------------------------------------------------------------- 
     2053  IMPLICIT NONE 
     2054!- 
     2055  INTEGER :: fid 
     2056  CHARACTER(LEN=*) :: vname_q 
     2057  INTEGER :: iim,jjm,llm,mmm,itau 
     2058  REAL :: var(:,:,:,:) 
     2059  CHARACTER(LEN=*) :: MY_OPERATOR 
     2060  INTEGER :: nbindex,ijndex(nbindex) 
     2061!- 
     2062  INTEGER :: jj,ll,mm,req_sz,ist,siz1 
     2063  REAL :: scal 
     2064  CHARACTER(LEN=7) :: topp 
     2065  LOGICAL :: l_dbg 
     2066  INTEGER :: list_dims(5) 
     2067!--------------------------------------------------------------------- 
     2068  CALL ipsldbg (old_status=l_dbg) 
     2069!- 
     2070! 0.0 What size should be the data in the file 
     2071!- 
     2072  req_sz = 1 
     2073  IF ( nbindex == iim) THEN 
     2074    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     2075    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
     2076  ELSE 
     2077    CALL ipslerr (3,'restput_opp_r4d', & 
     2078      'Unable to performe an operation on this variable as it has', & 
     2079      'a second and third dimension',vname_q) 
     2080  ENDIF 
     2081!- 
     2082  IF (jjm < 1 .OR. llm < 1 .OR. mmm < 1) THEN 
     2083    CALL ipslerr (3,'restput_opp_r4d', & 
     2084      'Please specify a second dimension which is the', & 
     2085      'layer on which the operations are performed',vname_q) 
     2086  ENDIF 
     2087!- 
     2088! 1.0 Allocate the temporary buffer we need 
     2089!     to put the variable in right dimension 
     2090!- 
     2091  siz1 = SIZE(var,1) 
     2092  CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r4d') 
     2093  CALL rest_alloc (2,req_sz*jjm*llm*mmm,l_dbg,'restput_opp_r4d') 
     2094!- 
     2095! 2.0 We do the operation needed. 
     2096!     It can only be a re-indexing operation. 
     2097!     You would not want to change the values in a restart file or ? 
     2098!- 
     2099  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) 
     2100!- 
     2101  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN 
     2102    scal = missing_val 
     2103    DO mm = 1,mmm 
     2104      DO ll = 1,llm 
     2105        DO jj = 1,jjm 
     2106          buff_tmp1(1:siz1) = var(:,jj,ll,mm) 
     2107          ist = ((((mm-1)*llm + (ll-1))*jjm) + (jj-1))*req_sz+1 
     2108          CALL mathop & 
     2109 &        (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & 
     2110 &           scal,req_sz,buff_tmp2(ist:ist+req_sz-1)) 
     2111        ENDDO 
     2112      ENDDO 
     2113    ENDDO 
     2114  ELSE 
     2115    CALL ipslerr (3,'restput_opp_r4d', & 
     2116 &    'The operation you wish to do on the variable for the ', & 
     2117 &    'restart file is not allowed.',topp) 
     2118  ENDIF 
     2119!- 
     2120  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1),ax_infs(fid,RESTART_DIM_Y,1,1),jjm,llm,mmm /) 
     2121!- 
     2122  CALL restput_real & 
     2123 & (fid,vname_q,list_dims,itau,buff_tmp2) 
     2124!----------------------------- 
     2125END SUBROUTINE restput_opp_r4d 
     2126!=== 
     2127SUBROUTINE restput_opp_r5d & 
     2128 & (fid,vname_q,iim,jjm,llm,mmm,nnm,itau,var,MY_OPERATOR,nbindex,ijndex) 
     2129!--------------------------------------------------------------------- 
     2130!- This subroutine is the interface to restput_real which allows 
     2131!- to re-index data onto the original grid of the restart file. 
     2132!- The logic we use is still fuzzy in my mind but that is probably 
     2133!- only because I have not yet though through everything. 
     2134!- 
     2135!- In the case iim = nbindex it means that the user attempts 
     2136!- to project the first dimension of the matrix back onto a 3D field 
     2137!- where jjm will be the third dimension. 
     2138!--------------------------------------------------------------------- 
     2139  IMPLICIT NONE 
     2140!- 
     2141  INTEGER :: fid 
     2142  CHARACTER(LEN=*) :: vname_q 
     2143  INTEGER :: iim,jjm,llm,mmm,nnm,itau 
     2144  REAL :: var(:,:,:,:,:) 
     2145  CHARACTER(LEN=*) :: MY_OPERATOR 
     2146  INTEGER :: nbindex,ijndex(nbindex) 
     2147!- 
     2148  INTEGER :: jj,ll,mm,nn,req_sz,ist,siz1 
     2149  REAL :: scal 
     2150  CHARACTER(LEN=7) :: topp 
     2151  LOGICAL :: l_dbg 
     2152  INTEGER :: list_dims(6) 
     2153!--------------------------------------------------------------------- 
     2154  CALL ipsldbg (old_status=l_dbg) 
     2155!- 
     2156! 0.0 What size should be the data in the file 
     2157!- 
     2158  req_sz = 1 
     2159  IF ( nbindex == iim) THEN 
     2160    IF (ax_infs(fid,RESTART_DIM_X,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_X,1,1) 
     2161    IF (ax_infs(fid,RESTART_DIM_Y,1,1) > 0) req_sz = req_sz*ax_infs(fid,RESTART_DIM_Y,1,1) 
     2162  ELSE 
     2163    CALL ipslerr (3,'restput_opp_r5d', & 
     2164      'Unable to performe an operation on this variable as it has', & 
     2165      'a second and third dimension',vname_q) 
     2166  ENDIF 
     2167!- 
     2168  IF (jjm < 1 .OR. llm < 1 .OR. mmm < 1 .OR. nnm < 1) THEN 
     2169    CALL ipslerr (3,'restput_opp_r5d', & 
     2170      'Please make sure all dimenensions are at least 1', & 
     2171      '',vname_q) 
     2172  ENDIF 
     2173!- 
     2174! 1.0 Allocate the temporary buffer we need 
     2175!     to put the variable in right dimension 
     2176!- 
     2177  siz1 = SIZE(var,1) 
     2178  CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r5d') 
     2179  CALL rest_alloc (2,req_sz*jjm*llm*mmm*nnm,l_dbg,'restput_opp_r5d') 
     2180!- 
     2181! 2.0 We do the operation needed. 
     2182!     It can only be a re-indexing operation. 
     2183!     You would not want to change the values in a restart file or ? 
     2184!- 
     2185  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) 
     2186!- 
     2187  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN 
     2188    scal = missing_val 
     2189    DO nn = 1, nnm 
     2190      DO mm = 1,mmm 
     2191        DO ll = 1,llm 
     2192          DO jj = 1,jjm 
     2193            buff_tmp1(1:siz1) = var(:,jj,ll,mm,nn) 
     2194            ist = (((((nn-1) * mmm) + (mm-1)*llm + (ll-1))*jjm) + (jj-1))*req_sz+1 
     2195            CALL mathop & 
     2196 &          (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & 
     2197 &             scal,req_sz,buff_tmp2(ist:ist+req_sz-1)) 
     2198          ENDDO 
     2199        ENDDO 
     2200      ENDDO 
     2201    ENDDO 
     2202  ELSE 
     2203    CALL ipslerr (3,'restput_opp_r5d', & 
     2204 &    'The operation you wish to do on the variable for the ', & 
     2205 &    'restart file is not allowed.',topp) 
     2206  ENDIF 
     2207!- 
     2208  list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1),ax_infs(fid,RESTART_DIM_Y,1,1),jjm,llm,mmm,nnm /) 
     2209!- 
     2210  CALL restput_real & 
     2211 & (fid,vname_q,list_dims,itau,buff_tmp2) 
     2212!----------------------------- 
     2213END SUBROUTINE restput_opp_r5d 
    16852214!=== 
    16862215SUBROUTINE restput_r1d (fid,vname_q,iim,jjm,llm,itau,var) 
     
    16982227  CHARACTER(LEN=70) :: str,str2 
    16992228  LOGICAL :: l_dbg 
     2229  INTEGER :: list_dims(1) 
    17002230!--------------------------------------------------------------------- 
    17012231  CALL ipsldbg (old_status=l_dbg) 
     
    17042234!     to put the variable in right dimension 
    17052235!- 
     2236  list_dims(1) = iim 
    17062237  siz1 = SIZE(var) 
    17072238  var_sz = siz1 
     
    17382269  ENDDO 
    17392270!- 
    1740   CALL restput_real (fid,vname_q,iim,jjm,llm,itau,buff_tmp1) 
     2271  CALL restput_real (fid,vname_q,list_dims,itau,buff_tmp1) 
    17412272!------------------------- 
    17422273END SUBROUTINE restput_r1d 
     
    17562287  CHARACTER(LEN=70) :: str,str2 
    17572288  LOGICAL :: l_dbg 
     2289  INTEGER :: list_dims(2) 
    17582290!--------------------------------------------------------------------- 
    17592291  CALL ipsldbg (old_status=l_dbg) 
     
    17622294!     to put the variable in right dimension 
    17632295!- 
     2296  list_dims = (/ iim,jjm /) 
    17642297  siz1 = SIZE(var,1) 
    17652298  siz2 = SIZE(var,2) 
     
    17982331  ENDDO 
    17992332!- 
    1800   CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1) 
     2333  CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1) 
    18012334!------------------------- 
    18022335END SUBROUTINE restput_r2d 
     
    18162349  CHARACTER(LEN=70) :: str,str2 
    18172350  LOGICAL :: l_dbg 
     2351  INTEGER :: list_dims(3) 
    18182352!--------------------------------------------------------------------- 
    18192353  CALL ipsldbg (old_status=l_dbg) 
     
    18222356!     to put the variable in right dimension 
    18232357!- 
     2358  list_dims = (/ iim, jjm, llm /) 
    18242359  siz1 = SIZE(var,1) 
    18252360  siz2 = SIZE(var,2) 
     
    18622397  ENDDO 
    18632398!- 
    1864   CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1) 
     2399  CALL restput_real(fid,vname_q,list_dims,itau,buff_tmp1) 
    18652400!------------------------- 
    18662401END SUBROUTINE restput_r3d 
    18672402!=== 
    1868 SUBROUTINE restput_real (fid,vname_q,iim,jjm,llm,itau,var) 
     2403SUBROUTINE restput_real (fid,vname_q,list_dims,itau,var) 
    18692404!--------------------------------------------------------------------- 
    18702405!- This subroutine will put a variable into the restart file. 
     
    18832418!- fid         : Id of the file in which we will write the variable 
    18842419!- vname_q     : Name of the variable to be written 
    1885 !- iim,jjm,llm : Size in 3D of the variable 
     2420!- list_dim    : Size of the variable (1 to RESTART_MAX_DIMS) 
    18862421!- itau        : Time step at which the variable is written 
    18872422!- var         : Variable 
     
    18942429!- 
    18952430  CHARACTER(LEN=*) :: vname_q 
    1896   INTEGER :: fid,iim,jjm,llm,itau 
     2431  INTEGER :: fid,itau 
     2432  INTEGER,DIMENSION(:),INTENT(in) :: list_dims 
    18972433  REAL :: var(:) 
    18982434!- 
    1899   INTEGER :: iret,vid,ncid,iv,vnb 
     2435  INTEGER :: iret,vid,ncid,iv,vnb,itedim 
    19002436  INTEGER :: ierr 
    19012437  REAL :: secsince,one_day,one_year 
    19022438  INTEGER :: ndims 
    1903   INTEGER,DIMENSION(4) :: corner,edge 
     2439  INTEGER,DIMENSION(RESTART_MAX_DIMS) :: corner,edge 
    19042440  LOGICAL :: l_dbg 
    19052441!--------------------------------------------------------------------- 
     
    19162452!- 
    19172453! 0.0 show arguments 
    1918   IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 0.0 : ',netcdf_name(fid,2),vname_q,iim,jjm,llm,itau 
     2454  IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 0.0 : ',netcdf_name(fid,2),vname_q,list_dims,itau 
    19192455!- 
    19202456! 1.0 Check if the variable is already present 
     
    19322468!- 
    19332469  IF (vnb <= 0) THEN 
    1934     CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.) 
     2470    CALL restdefv (fid,vname_q,list_dims,.TRUE.) 
    19352471    vnb = nbvar_out(fid) 
    19362472  ENDIF 
     
    20052541!- 
    20062542  ndims = 0 
    2007   IF (iim > 0) THEN 
     2543  DO itedim=1, SIZE(list_dims,1) 
    20082544    ndims = ndims+1 
    20092545    corner(ndims) = 1 
    2010     edge(ndims) = iim 
    2011   ENDIF 
    2012   IF (jjm > 0) THEN 
    2013     ndims = ndims+1 
    2014     corner(ndims) = 1 
    2015     edge(ndims) = jjm 
    2016   ENDIF 
    2017   IF (llm > 0) THEN 
    2018     ndims = ndims+1 
    2019     corner(ndims) = 1 
    2020     edge(ndims) = llm 
    2021   ENDIF 
     2546    edge(ndims) = list_dims(itedim) 
     2547  ENDDO 
     2548 
    20222549  ndims = ndims+1 
    20232550  corner(ndims) = tstp_out(fid) 
     
    20282555!- 
    20292556  IF (iret /= NF90_NOERR) THEN 
    2030     CALL ipslerr (2,'restput_real',NF90_STRERROR(iret), & 
     2557    CALL ipslerr (3,'restput_real',NF90_STRERROR(iret), & 
    20312558 &    'Bug in restput.',& 
    20322559 &    'Please, verify compatibility between get and put commands.') 
     
    20392566END  SUBROUTINE restput_real 
    20402567!=== 
    2041 SUBROUTINE restdefv (fid,varname,iim,jjm,llm,write_att) 
     2568SUBROUTINE restdefv (fid,varname,list_dims,write_att) 
    20422569!--------------------------------------------------------------------- 
    20432570! This subroutine adds a variable to the output file. 
     
    20482575  INTEGER ::fid 
    20492576  CHARACTER(LEN=*) :: varname 
    2050   INTEGER :: iim,jjm,llm 
     2577! define its dimension size, this must respect same order as RESTART_DIMS_NAMES 
     2578! x,y,z,.... 
     2579  INTEGER, DIMENSION(:),INTENT(in) :: list_dims  ! Dimensions input 
    20512580  LOGICAL :: write_att 
    20522581!- 
    2053   INTEGER :: dims(4),ic,xloc,ndim,ncfid 
    2054   INTEGER :: iret,ax_id 
     2582  INTEGER :: dims(RESTART_MAX_DIMS),ic,xloc,ndim,ncfid 
     2583  INTEGER :: iret,ax_id,ite 
    20552584  CHARACTER(LEN=3) :: str 
    20562585  LOGICAL :: l_dbg 
    20572586!--------------------------------------------------------------------- 
    20582587  CALL ipsldbg (old_status=l_dbg) 
     2588!- Check consistency 
     2589!- 
     2590  IF (ANY(list_dims < 1)) THEN 
     2591    CALL ipslerr (3,'restdefv', & 
     2592      'All defined dimension sizes must be bigger than 0', & 
     2593      'Please check list_dims argument',' ') 
     2594  ENDIF 
     2595!- 
     2596  IF (SIZE(list_dims,1) == 0) THEN 
     2597    CALL ipslerr (3,'restdefv', & 
     2598      'You must add at least one dimension', & 
     2599      'Please check list_dims argument',' ') 
     2600  ENDIF 
     2601!- 
     2602  IF (SIZE(list_dims,1) > RESTART_MAX_DIMS) THEN 
     2603    CALL ipslerr (3,'restdefv', & 
     2604      'Maximum limit of dimensions in 1 variable reached', & 
     2605      'Please increase RESTART_MAX_DIM value',' ') 
     2606  ENDIF 
    20592607!- 
    20602608  ncfid = netcdf_id(fid,2) 
     
    20842632  ndim = 0 
    20852633!- 
    2086 ! 1.1 Work on x 
    2087 !- 
    2088   IF (iim > 0) THEN 
    2089     ndim = ndim+1 
    2090     xloc = 0 
    2091     DO ic=1,xax_nb(fid) 
    2092       IF (xax_infs(fid,ic,1) == iim) xloc = ic 
    2093     ENDDO 
    2094 !--- 
    2095     IF (xloc > 0) THEN 
    2096       dims(ndim) = xax_infs(fid,xloc,2) 
    2097     ELSE 
    2098       str='x_'//CHAR(96+xax_nb(fid)) 
    2099       iret = NF90_DEF_DIM(ncfid,str,iim,ax_id) 
    2100       xax_nb(fid) = xax_nb(fid)+1 
    2101       xax_infs(fid,xax_nb(fid),1) = iim 
    2102       xax_infs(fid,xax_nb(fid),2) = ax_id 
    2103       dims(ndim) = ax_id 
    2104     ENDIF 
    2105   ENDIF 
    2106 !- 
    2107 ! 1.2 Work on y 
    2108 !- 
    2109   IF (jjm > 0) THEN 
    2110     ndim = ndim+1 
    2111     xloc = 0 
    2112     DO ic=1,yax_nb(fid) 
    2113       IF (yax_infs(fid,ic,1) == jjm) xloc = ic 
    2114     ENDDO 
    2115 !--- 
    2116     IF (xloc > 0) THEN 
    2117       dims(ndim) = yax_infs(fid,xloc,2) 
    2118     ELSE 
    2119       str='y_'//CHAR(96+yax_nb(fid)) 
    2120       iret = NF90_DEF_DIM(ncfid,str,jjm,ax_id) 
    2121       yax_nb(fid) = yax_nb(fid)+1 
    2122       yax_infs(fid,yax_nb(fid),1) = jjm 
    2123       yax_infs(fid,yax_nb(fid),2) = ax_id 
    2124       dims(ndim) = ax_id 
    2125     ENDIF 
    2126   ENDIF 
    2127 !- 
    2128 ! 1.3 Work on z 
    2129 !- 
    2130   IF (llm > 0) THEN 
    2131     ndim = ndim+1 
    2132     xloc = 0 
    2133     DO ic=1,zax_nb(fid) 
    2134       IF (zax_infs(fid,ic,1) == llm) xloc = ic 
    2135     ENDDO 
    2136 !--- 
    2137     IF (xloc > 0) THEN 
    2138       dims(ndim) = zax_infs(fid,xloc,2) 
    2139     ELSE 
    2140       str='z_'//CHAR(96+zax_nb(fid)) 
    2141       iret = NF90_DEF_DIM(ncfid,str,llm,ax_id) 
    2142       zax_nb(fid) = zax_nb(fid)+1 
    2143       zax_infs(fid,zax_nb(fid),1) = llm 
    2144       zax_infs(fid,zax_nb(fid),2) = ax_id 
    2145       dims(ndim) = ax_id 
    2146     ENDIF 
    2147   ENDIF 
     2634! 1.1 Work on each dimension 
     2635!- 
     2636  DO ite=1, SIZE(list_dims, 1)   
     2637    IF (list_dims(ite) > 0) THEN 
     2638      ndim = ndim+1 
     2639      xloc = 0 
     2640      DO ic=1,ax_nb(fid, ite) 
     2641        IF (ax_infs(fid,ite,ic,1) == list_dims(ite)) xloc = ic 
     2642      ENDDO 
     2643!--- 
     2644      IF (xloc > 0) THEN 
     2645        dims(ndim) = ax_infs(fid,ite,xloc,2) 
     2646      ELSE 
     2647        str=RESTART_DIMS_NAMES(ite)//'_'//CHAR(96+ax_nb(fid,ite)) 
     2648        iret = NF90_DEF_DIM(ncfid,str,list_dims(ite),ax_id) 
     2649        ax_nb(fid,ite) = ax_nb(fid,ite)+1 
     2650        ax_infs(fid,ite,ax_nb(fid,ite),1) = list_dims(ite) 
     2651        ax_infs(fid,ite,ax_nb(fid,ite),2) = ax_id 
     2652        dims(ndim) = ax_id 
     2653      ENDIF 
     2654    ENDIF 
     2655  ENDDO 
    21482656!- 
    21492657! 1.4  Time needs to be added 
     
    21832691    iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & 
    21842692 &                      'missing_value',REAL(missing_val,KIND=4)) 
     2693!--- 
     2694    iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & 
     2695 &                      '_FillValue',REAL(val_exp,r_std)) 
    21852696!--- 
    21862697    IF (itau_out(fid) >= 0) THEN 
Note: See TracChangeset for help on using the changeset viewer.