Changeset 3188
 Timestamp:
 03/24/17 14:36:20 (7 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

IOIPSL/trunk/src/restcom.f90
r2020 r3188 8 8 USE netcdf 9 9 ! 10 USE defprec 10 11 USE errioipsl, ONLY : ipslerr,ipsldbg, ipslout 11 12 USE stringop … … 26 27 MODULE PROCEDURE & 27 28 & 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 29 31 END INTERFACE 30 32 ! … … 32 34 MODULE PROCEDURE & 33 35 & 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 35 38 END INTERFACE 36 39 ! … … 40 43 ! 41 44 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) 43 47 ! 44 48 CHARACTER(LEN=9),SAVE :: calend_str='unknown' … … 88 92 ! ?ax_nb(if) 89 93 ! 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 94 109 ! 95 110 ! Description of the time axes in the input and output files … … 158 173 SUBROUTINE restini & 159 174 & (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 ) 161 176 ! 162 177 ! This subroutine sets up all the restart process. … … 203 218 ! overwrite the time in the restart file 204 219 ! domain_id : Domain identifier 220 ! 205 221 ! 206 222 IMPLICIT NONE … … 242 258 & 'and recompiling ioipsl.') 243 259 ENDIF 244 !245 ! 0.1 Define the open flags246 260 ! 247 261 l_fi = (TRIM(fnamein) /= 'NONE') … … 407 421 ! then we open it in write mode 408 422 ! 409 IF (l_rw) THEN; id = NF90_WRITE; ELSE; id = NF90_NOWRITE; ENDIF423 IF (l_rw) THEN; id = IOR(NF90_WRITE,NF90_NETCDF4); ELSE; id = IOR(NF90_NOWRITE,NF90_NETCDF4); ENDIF 410 424 iret = NF90_OPEN(fname,id,ncfid) 411 425 IF (iret /= NF90_NOERR) THEN … … 440 454 WRITE (*,*) "restopenin 0.0 dimname",id,TRIM(dimname(id)) 441 455 ENDIF 442 IF (TRIM(dimname(id)) == 'x') THEN456 IF (TRIM(dimname(id)) == RESTART_DIMS_NAMES(RESTART_DIM_X)) THEN 443 457 iread = dimlen(id) 444 458 IF (l_dbg) WRITE (*,*) "iread",iread 445 ELSE IF (TRIM(dimname(id)) == 'y') THEN459 ELSE IF (TRIM(dimname(id)) == RESTART_DIMS_NAMES(RESTART_DIM_Y)) THEN 446 460 jread = dimlen(id) 447 461 IF (l_dbg) WRITE (*,*) "jread",jread 448 ELSE IF (TRIM(dimname(id)) == 'z') THEN462 ELSE IF (TRIM(dimname(id)) == RESTART_DIMS_NAMES(RESTART_DIM_Z)) THEN 449 463 lread = dimlen(id) 450 464 IF (l_dbg) WRITE (*,*) "lread",lread … … 468 482 ENDIF 469 483 ! 470 xax_nb(fid) = 0 471 yax_nb(fid) = 0 472 zax_nb(fid) = 0 484 ax_nb(fid,:) = 0 473 485 ! 474 486 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 487 492 ENDIF 493 ENDDO 494 ! 495 ! Initialize non basic dimensions 496 ! 497 DO id=4,RESTART_MAX_DIMS 498 ax_nb(fid,id) = 1 488 499 ENDDO 489 500 ENDIF … … 832 843 CHARACTER(LEN=30) :: timenow 833 844 LOGICAL :: l_dbg 845 INTEGER :: cmode, id 834 846 ! 835 847 CALL ipsldbg (old_status=l_dbg) … … 840 852 ! we will not even call restopenout 841 853 ! 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) 843 855 IF (iret == 35) THEN 844 856 CALL ipslerr (3,'restopenout',& … … 847 859 & ' generate the new one with another name') 848 860 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 864 882 ! 865 883 iret = NF90_DEF_DIM(ncfid,'time',NF90_UNLIMITED,tdimid_out(fid)) … … 1014 1032 CHARACTER(LEN=7) :: topp 1015 1033 LOGICAL :: l_dbg 1034 INTEGER :: list_dims(2) ! x and y 1016 1035 ! 1017 1036 CALL ipsldbg (old_status=l_dbg) … … 1021 1040 req_sz = 1 1022 1041 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) 1026 1045 ELSE 1027 1046 CALL ipslerr (3,'resget_opp_r1d', & … … 1039 1058 ! 2.0 Here we get the variable from the restart file 1040 1059 ! 1060 list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1) /) 1061 ! 1041 1062 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) 1044 1064 ! 1045 1065 ! 4.0 Transfer the buffer obtained from the restart file … … 1083 1103 CHARACTER(LEN=7) :: topp 1084 1104 LOGICAL :: l_dbg 1105 INTEGER :: list_dims(3) 1085 1106 ! 1086 1107 CALL ipsldbg (old_status=l_dbg) … … 1090 1111 req_sz = 1 1091 1112 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) 1094 1115 ELSE 1095 1116 CALL ipslerr (3,'resget_opp_r2d', & … … 1113 1134 ! 2.0 Here we get the full variable from the restart file 1114 1135 ! 1136 list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1), jjm /) 1137 ! 1115 1138 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) 1118 1140 ! 1119 1141 ! 4.0 Transfer the buffer obtained from the restart file … … 1139 1161 END SUBROUTINE restget_opp_r2d 1140 1162 !=== 1163 SUBROUTINE 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 = (((ll1)*jjm) + (jj1))*req_sz+1 1238 CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz1), & 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 ! 1249 END SUBROUTINE restget_opp_r3d 1250 !=== 1251 SUBROUTINE 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 = ((((mm1)*llm + (ll1))*jjm) + (jj1))*req_sz+1 1315 CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz1), & 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 ! 1327 END SUBROUTINE restget_opp_r4d 1328 !=== 1329 SUBROUTINE 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 = (((((nn1)*mmm) + (mm1)*llm + (ll1))*jjm) + (jj1))*req_sz+1 1394 CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz1), & 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 ! 1407 END SUBROUTINE restget_opp_r5d 1408 !=== 1141 1409 SUBROUTINE restget_r1d & 1142 1410 & (fid,vname_q,iim,jjm,llm,itau,def_beha,var) … … 1155 1423 CHARACTER(LEN=70) :: str,str2 1156 1424 LOGICAL :: l_dbg 1425 INTEGER :: list_dims(2) 1157 1426 ! 1158 1427 CALL ipsldbg (old_status=l_dbg) … … 1188 1457 ENDIF 1189 1458 ! 1459 list_dims = (/ iim,jjm /) 1460 ! 1190 1461 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) 1192 1463 ! 1193 1464 ! 4.0 Transfer the buffer obtained from the restart file … … 1218 1489 CHARACTER(LEN=70) :: str,str2 1219 1490 LOGICAL :: l_dbg 1491 INTEGER :: list_dims(2) 1220 1492 ! 1221 1493 CALL ipsldbg (old_status=l_dbg) … … 1253 1525 ENDIF 1254 1526 ! 1527 list_dims = (/ iim,jjm /) 1528 ! 1255 1529 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) 1257 1531 ! 1258 1532 ! 4.0 Transfer the buffer obtained from the restart file … … 1285 1559 CHARACTER(LEN=70) :: str,str2 1286 1560 LOGICAL :: l_dbg 1561 INTEGER :: list_dims(3) 1287 1562 ! 1288 1563 CALL ipsldbg (old_status=l_dbg) … … 1321 1596 ENDIF 1322 1597 ! 1598 list_dims = (/ iim,jjm,llm /) 1599 ! 1323 1600 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) 1325 1602 ! 1326 1603 ! 4.0 Transfer the buffer obtained from the restart file … … 1340 1617 !=== 1341 1618 SUBROUTINE restget_real & 1342 (fid,vname_q, iim,jjm,llm,itau,def_beha,var)1619 (fid,vname_q,list_dims,itau,def_beha,var) 1343 1620 ! 1344 1621 ! This subroutine is for getting a variable from the restart file. … … 1368 1645 INTEGER :: fid 1369 1646 CHARACTER(LEN=*) :: vname_q 1370 INTEGER :: iim,jjm,llm,itau 1647 INTEGER,DIMENSION(:),INTENT(in) :: list_dims 1648 INTEGER :: itau 1371 1649 LOGICAL :: def_beha 1372 1650 REAL :: var(:) 1373 1651 ! 1374 INTEGER :: vid,vnb,ncfid,iret,index,it,ndim,ia 1652 INTEGER :: vid,vnb,ncfid,iret,index,it,ndim,ia,itedim 1375 1653 CHARACTER(LEN=70) str,str2 1376 1654 CHARACTER(LEN=80) attname 1377 INTEGER,DIMENSION( 4) :: corner,edge1655 INTEGER,DIMENSION(RESTART_MAX_DIMS) :: corner,edge 1378 1656 LOGICAL :: l_dbg 1379 1657 ! 1380 1658 CALL ipsldbg (old_status=l_dbg) 1381 1659 ! 1382 IF (l_dbg) WRITE(ipslout,*) 'RESTGET 0.0 : ',netcdf_name(fid,2),vname_q, iim,jjm,llm,itau,def_beha1660 IF (l_dbg) WRITE(ipslout,*) 'RESTGET 0.0 : ',netcdf_name(fid,2),vname_q,list_dims,itau,def_beha 1383 1661 ! 1384 1662 ncfid = netcdf_id(fid,1) … … 1390 1668 ! 1391 1669 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 1392 1685 ! 1393 1686 IF (vnb < 0) THEN … … 1412 1705 touched_in(fid,vnb) = .TRUE. 1413 1706 ! 1414 CALL restdefv (fid,vname_q, iim,jjm,llm,.TRUE.)1707 CALL restdefv (fid,vname_q,list_dims,.TRUE.) 1415 1708 IF (l_dbg) WRITE(ipslout,*) 'RESTGET 1.1 : ',vnb 1416 1709 ! … … 1457 1750 str='Incorrect dimension for '//TRIM(vname_q) 1458 1751 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 1494 1764 ! 1495 1765 ! Time … … 1497 1767 ndim = ndim+1 1498 1768 corner(ndim) = index 1499 !!????? edge(ndim) = index1500 1769 edge(ndim) = 1 1501 1770 ! … … 1510 1779 & .AND.(netcdf_id(fid,2) > 0) ) THEN 1511 1780 ! 1512 CALL restdefv (fid,vname_q, iim,jjm,llm,.FALSE.)1781 CALL restdefv (fid,vname_q,list_dims,.FALSE.) 1513 1782 ! 1514 1783 DO ia = 1,varatt_in(fid,vnb) … … 1553 1822 CHARACTER(LEN=7) :: topp 1554 1823 LOGICAL :: l_dbg 1824 INTEGER :: list_dims(2) 1555 1825 ! 1556 1826 CALL ipsldbg (old_status=l_dbg) … … 1560 1830 req_sz = 1 1561 1831 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) 1565 1834 ELSE 1566 1835 CALL ipslerr (3,'restput_opp_r1d', & … … 1594 1863 ENDIF 1595 1864 ! 1865 list_dims = (/ ax_infs(fid,RESTART_DIM_X,1,1), ax_infs(fid,RESTART_DIM_Y,1,1) /) 1866 ! 1596 1867 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) 1599 1869 ! 1600 1870 END SUBROUTINE restput_opp_r1d … … 1629 1899 CHARACTER(LEN=7) :: topp 1630 1900 LOGICAL :: l_dbg 1901 INTEGER :: list_dims(3) 1631 1902 ! 1632 1903 CALL ipsldbg (old_status=l_dbg) … … 1636 1907 req_sz = 1 1637 1908 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) 1640 1911 ELSE 1641 1912 CALL ipslerr (3,'restput_opp_r2d', & … … 1678 1949 ENDIF 1679 1950 ! 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) 1683 1954 ! 1684 1955 END SUBROUTINE restput_opp_r2d 1956 !=== 1957 SUBROUTINE 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 reindex 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 reindexing 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 = (((ll1)*jjm) + (jj1))*req_sz+1 2023 CALL mathop & 2024 & (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & 2025 & scal,req_sz,buff_tmp2(ist:ist+req_sz1)) 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 ! 2039 END SUBROUTINE restput_opp_r3d 2040 !=== 2041 SUBROUTINE 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 reindex 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 reindexing 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 = ((((mm1)*llm + (ll1))*jjm) + (jj1))*req_sz+1 2108 CALL mathop & 2109 & (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & 2110 & scal,req_sz,buff_tmp2(ist:ist+req_sz1)) 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 ! 2125 END SUBROUTINE restput_opp_r4d 2126 !=== 2127 SUBROUTINE 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 reindex 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 reindexing 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 = (((((nn1) * mmm) + (mm1)*llm + (ll1))*jjm) + (jj1))*req_sz+1 2195 CALL mathop & 2196 & (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & 2197 & scal,req_sz,buff_tmp2(ist:ist+req_sz1)) 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 ! 2213 END SUBROUTINE restput_opp_r5d 1685 2214 !=== 1686 2215 SUBROUTINE restput_r1d (fid,vname_q,iim,jjm,llm,itau,var) … … 1698 2227 CHARACTER(LEN=70) :: str,str2 1699 2228 LOGICAL :: l_dbg 2229 INTEGER :: list_dims(1) 1700 2230 ! 1701 2231 CALL ipsldbg (old_status=l_dbg) … … 1704 2234 ! to put the variable in right dimension 1705 2235 ! 2236 list_dims(1) = iim 1706 2237 siz1 = SIZE(var) 1707 2238 var_sz = siz1 … … 1738 2269 ENDDO 1739 2270 ! 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) 1741 2272 ! 1742 2273 END SUBROUTINE restput_r1d … … 1756 2287 CHARACTER(LEN=70) :: str,str2 1757 2288 LOGICAL :: l_dbg 2289 INTEGER :: list_dims(2) 1758 2290 ! 1759 2291 CALL ipsldbg (old_status=l_dbg) … … 1762 2294 ! to put the variable in right dimension 1763 2295 ! 2296 list_dims = (/ iim,jjm /) 1764 2297 siz1 = SIZE(var,1) 1765 2298 siz2 = SIZE(var,2) … … 1798 2331 ENDDO 1799 2332 ! 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) 1801 2334 ! 1802 2335 END SUBROUTINE restput_r2d … … 1816 2349 CHARACTER(LEN=70) :: str,str2 1817 2350 LOGICAL :: l_dbg 2351 INTEGER :: list_dims(3) 1818 2352 ! 1819 2353 CALL ipsldbg (old_status=l_dbg) … … 1822 2356 ! to put the variable in right dimension 1823 2357 ! 2358 list_dims = (/ iim, jjm, llm /) 1824 2359 siz1 = SIZE(var,1) 1825 2360 siz2 = SIZE(var,2) … … 1862 2397 ENDDO 1863 2398 ! 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) 1865 2400 ! 1866 2401 END SUBROUTINE restput_r3d 1867 2402 !=== 1868 SUBROUTINE restput_real (fid,vname_q, iim,jjm,llm,itau,var)2403 SUBROUTINE restput_real (fid,vname_q,list_dims,itau,var) 1869 2404 ! 1870 2405 ! This subroutine will put a variable into the restart file. … … 1883 2418 ! fid : Id of the file in which we will write the variable 1884 2419 ! vname_q : Name of the variable to be written 1885 ! iim,jjm,llm : Size in 3D of the variable2420 ! list_dim : Size of the variable (1 to RESTART_MAX_DIMS) 1886 2421 ! itau : Time step at which the variable is written 1887 2422 ! var : Variable … … 1894 2429 ! 1895 2430 CHARACTER(LEN=*) :: vname_q 1896 INTEGER :: fid,iim,jjm,llm,itau 2431 INTEGER :: fid,itau 2432 INTEGER,DIMENSION(:),INTENT(in) :: list_dims 1897 2433 REAL :: var(:) 1898 2434 ! 1899 INTEGER :: iret,vid,ncid,iv,vnb 2435 INTEGER :: iret,vid,ncid,iv,vnb,itedim 1900 2436 INTEGER :: ierr 1901 2437 REAL :: secsince,one_day,one_year 1902 2438 INTEGER :: ndims 1903 INTEGER,DIMENSION( 4) :: corner,edge2439 INTEGER,DIMENSION(RESTART_MAX_DIMS) :: corner,edge 1904 2440 LOGICAL :: l_dbg 1905 2441 ! … … 1916 2452 ! 1917 2453 ! 0.0 show arguments 1918 IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 0.0 : ',netcdf_name(fid,2),vname_q, iim,jjm,llm,itau2454 IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 0.0 : ',netcdf_name(fid,2),vname_q,list_dims,itau 1919 2455 ! 1920 2456 ! 1.0 Check if the variable is already present … … 1932 2468 ! 1933 2469 IF (vnb <= 0) THEN 1934 CALL restdefv (fid,vname_q, iim,jjm,llm,.TRUE.)2470 CALL restdefv (fid,vname_q,list_dims,.TRUE.) 1935 2471 vnb = nbvar_out(fid) 1936 2472 ENDIF … … 2005 2541 ! 2006 2542 ndims = 0 2007 IF (iim > 0) THEN2543 DO itedim=1, SIZE(list_dims,1) 2008 2544 ndims = ndims+1 2009 2545 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 2022 2549 ndims = ndims+1 2023 2550 corner(ndims) = tstp_out(fid) … … 2028 2555 ! 2029 2556 IF (iret /= NF90_NOERR) THEN 2030 CALL ipslerr ( 2,'restput_real',NF90_STRERROR(iret), &2557 CALL ipslerr (3,'restput_real',NF90_STRERROR(iret), & 2031 2558 & 'Bug in restput.',& 2032 2559 & 'Please, verify compatibility between get and put commands.') … … 2039 2566 END SUBROUTINE restput_real 2040 2567 !=== 2041 SUBROUTINE restdefv (fid,varname, iim,jjm,llm,write_att)2568 SUBROUTINE restdefv (fid,varname,list_dims,write_att) 2042 2569 ! 2043 2570 ! This subroutine adds a variable to the output file. … … 2048 2575 INTEGER ::fid 2049 2576 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 2051 2580 LOGICAL :: write_att 2052 2581 ! 2053 INTEGER :: dims( 4),ic,xloc,ndim,ncfid2054 INTEGER :: iret,ax_id 2582 INTEGER :: dims(RESTART_MAX_DIMS),ic,xloc,ndim,ncfid 2583 INTEGER :: iret,ax_id,ite 2055 2584 CHARACTER(LEN=3) :: str 2056 2585 LOGICAL :: l_dbg 2057 2586 ! 2058 2587 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 2059 2607 ! 2060 2608 ncfid = netcdf_id(fid,2) … … 2084 2632 ndim = 0 2085 2633 ! 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 2148 2656 ! 2149 2657 ! 1.4 Time needs to be added … … 2183 2691 iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & 2184 2692 & '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)) 2185 2696 ! 2186 2697 IF (itau_out(fid) >= 0) THEN
Note: See TracChangeset
for help on using the changeset viewer.