|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
00001 ! ******************************************************************* 00002 ! ******************************************************************* 00003 ! ******************************************************************* 00004 ! 00005 !* *** WRITE_FILER4*** PRISM 1.0 00006 ! 00007 ! purpose: 00008 ! -------- 00009 ! At last time step, writes fields to binary files or netcdf files. 00010 ! 00011 ! interface: 00012 ! ---------- 00013 ! out_fld : field to be written to the restart file 00014 ! cd_port : symbolic name of the field 00015 ! id_port : port number of the field 00016 ! 00017 ! lib mp: 00018 ! ------- 00019 ! mpi-1 00020 ! 00021 ! author: 00022 ! ------- 00023 ! Eric Sevault - METEO FRANCE 00024 ! Laurent Terray - CERFACS 00025 ! Jean Latour - F.S.E. (mpi-2) 00026 ! Arnaud Caubel - Adaptation to PRISM interface 00027 ! ---------------------------------------------------------------- 00028 SUBROUTINE write_filer4(out_fld, cd_port,id_port) 00029 ! ---------------------------------------------------------------- 00030 USE mod_kinds_model 00031 USE mod_prism_proto 00032 USE mod_comprism_proto 00033 IMPLICIT NONE 00034 #ifdef use_netCDF 00035 #include <netcdf.inc> 00036 #endif 00037 ! ---------------------------------------------------------------- 00038 INTEGER (kind=ip_intwp_p), intent(in) :: id_port 00039 REAL(kind=ip_single_p), intent(in) :: out_fld(myport(4,id_port)) 00040 CHARACTER(len=8), intent(in) :: cd_port 00041 ! ---------------------------------------------------------------- 00042 INTEGER (kind=ip_intwp_p) :: il_unit, il_nolocal, il_err 00043 INTEGER (kind=ip_intwp_p) :: ierror, il_varid, il_ncid, istatus 00044 LOGICAL :: ll_file 00045 ! ---------------------------------------------------------------- 00046 #ifdef __VERBOSE 00047 WRITE(nulprt,*)' ' 00048 WRITE(nulprt,*)'| | | Entering write_filer4 ' 00049 CALL FLUSH(nulprt) 00050 #endif 00051 ! 00052 !* Test if restart file is in NETCDF format or not 00053 ! 00054 #ifdef use_netCDF 00055 IF (lg_ncdfrst) THEN 00056 ! 00057 !* Case NETCDF format 00058 ! 00059 istatus = NF_OPEN(cg_def_rstfile(id_port),NF_WRITE,il_ncid) 00060 IF (istatus.ne.NF_NOERR) THEN 00061 WRITE(nulprt,*) NF_STRERROR(istatus) 00062 WRITE(nulprt,*)' stop in write_filer4 routine 1' 00063 call MPI_ABORT (mpi_comm, 0, mpi_err) 00064 ENDIF 00065 istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid) 00066 IF (istatus.ne.NF_NOERR) THEN 00067 WRITE(nulprt,*) NF_STRERROR(istatus) 00068 WRITE(nulprt,*)' stop in write_filer4 routine 2' 00069 call MPI_ABORT (mpi_comm, 0, mpi_err) 00070 ENDIF 00071 istatus = NF_PUT_VAR_REAL (il_ncid, il_varid, out_fld) 00072 IF (istatus.ne.NF_NOERR) THEN 00073 WRITE(nulprt,*) NF_STRERROR(istatus) 00074 WRITE(nulprt,*)' stop in write_filer4 routine 3' 00075 call MPI_ABORT (mpi_comm, 0, mpi_err) 00076 ENDIF 00077 istatus = NF_CLOSE(il_ncid) 00078 IF (istatus.ne.NF_NOERR) THEN 00079 WRITE(nulprt,*) NF_STRERROR(istatus) 00080 WRITE(nulprt,*)' stop in write_filer4 routine 4' 00081 call MPI_ABORT (mpi_comm, 0, mpi_err) 00082 ENDIF 00083 ELSE 00084 #endif 00085 ! 00086 !* Case binary format 00087 ! 00088 IF (.not.allocated(ig_aux)) THEN 00089 ALLOCATE (ig_aux(ig_nbr_rstfile), stat=il_err) 00090 IF (il_ERR.ne.0) & 00091 WRITE(nulprt,*)'Error in "ig_aux" allocation in write_filer4 routine ! ' 00092 ig_aux(:) = 0 00093 ENDIF 00094 il_unit = nulprt + 1 00095 INQUIRE (il_unit,OPENED = ll_file) 00096 DO WHILE (ll_file) 00097 il_unit = il_unit + 1 00098 INQUIRE (il_unit,OPENED = ll_file) 00099 END DO 00100 il_nolocal = ig_def_norstfile(id_port) 00101 ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1 00102 IF (ig_aux(il_nolocal).eq.1) THEN 00103 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00104 FORM='UNFORMATTED') 00105 ELSE 00106 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00107 position='append', FORM='UNFORMATTED') 00108 ENDIF 00109 CALL locwriter4(cd_port,out_fld,myport(4,id_port),il_unit, & 00110 ierror, nulprt) 00111 CLOSE (il_unit) 00112 #ifdef use_netCDF 00113 ENDIF 00114 #endif 00115 #ifdef __VERBOSE 00116 WRITE(nulprt,*)'| | | Leaving write_filer4 ' 00117 WRITE(nulprt,*)' ' 00118 CALL FLUSH(nulprt) 00119 #endif 00120 END SUBROUTINE write_filer4 00121 00122 ! ******************************************************************** 00123 ! ******************************************************************** 00124 ! ******************************************************************** 00125 ! 00126 !* *** WRITE_FILER8*** PRISM 1.0 00127 ! 00128 ! purpose: 00129 ! -------- 00130 ! At last time step, writes fields to binary files or netcdf files. 00131 ! 00132 ! interface: 00133 ! ---------- 00134 ! out_fld : field to be written to the restart file 00135 ! cd_port : symbolic name of the field 00136 ! id_port : port number of the field 00137 ! 00138 ! lib mp: 00139 ! ------- 00140 ! mpi-1 00141 ! 00142 ! author: 00143 ! ------- 00144 ! Eric Sevault - METEO FRANCE 00145 ! Laurent Terray - CERFACS 00146 ! Jean Latour - F.S.E. (mpi-2) 00147 ! Arnaud Caubel - Adaptation to PRISM interface 00148 ! ---------------------------------------------------------------- 00149 SUBROUTINE write_filer8(out_fld, cd_port, id_port) 00150 ! ---------------------------------------------------------------- 00151 USE mod_kinds_model 00152 USE mod_prism_proto 00153 USE mod_comprism_proto 00154 IMPLICIT NONE 00155 #ifdef use_netCDF 00156 #include <netcdf.inc> 00157 #endif 00158 ! ---------------------------------------------------------------- 00159 INTEGER (kind=ip_intwp_p), intent(in) :: id_port 00160 CHARACTER(len=8), intent(in) :: cd_port 00161 REAL(kind=ip_double_p), intent(in) :: out_fld(myport(4,id_port)) 00162 ! ---------------------------------------------------------------- 00163 INTEGER (kind=ip_intwp_p) il_unit, il_nolocal, il_err 00164 INTEGER (kind=ip_intwp_p) ierror, il_varid, il_ncid, istatus 00165 LOGICAL ll_file 00166 ! ---------------------------------------------------------------- 00167 #ifdef __VERBOSE 00168 WRITE(nulprt,*)' ' 00169 WRITE(nulprt,*)'| | | Entering write_filer8 ' 00170 CALL FLUSH(nulprt) 00171 #endif 00172 ! 00173 !* Test if restart file is in NETCDF format or not 00174 ! 00175 #ifdef use_netCDF 00176 IF (lg_ncdfrst) THEN 00177 ! 00178 !* Case NETCDF format 00179 ! 00180 istatus = NF_OPEN(cg_def_rstfile(id_port),NF_WRITE,il_ncid) 00181 IF (istatus.ne.NF_NOERR) THEN 00182 WRITE(nulprt,*) NF_STRERROR(istatus) 00183 WRITE(nulprt,*)' stop in write_filer8 routine 1' 00184 call MPI_ABORT (mpi_comm, 0, mpi_err) 00185 ENDIF 00186 istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid) 00187 IF (istatus.ne.NF_NOERR) THEN 00188 WRITE(nulprt,*) NF_STRERROR(istatus) 00189 WRITE(nulprt,*)' stop in write_filer8 routine 2' 00190 call MPI_ABORT (mpi_comm, 0, mpi_err) 00191 ENDIF 00192 istatus = NF_PUT_VAR_DOUBLE (il_ncid, il_varid, out_fld) 00193 IF (istatus.ne.NF_NOERR) THEN 00194 WRITE(nulprt,*) NF_STRERROR(istatus) 00195 WRITE(nulprt,*)' stop in write_filer8 routine 3' 00196 call MPI_ABORT (mpi_comm, 0, mpi_err) 00197 ENDIF 00198 istatus = NF_CLOSE(il_ncid) 00199 IF (istatus.ne.NF_NOERR) THEN 00200 WRITE(nulprt,*) NF_STRERROR(istatus) 00201 WRITE(nulprt,*)' stop in write_filer8 routine 4' 00202 call MPI_ABORT (mpi_comm, 0, mpi_err) 00203 ENDIF 00204 ELSE 00205 #endif 00206 ! 00207 !* Case binary format 00208 ! 00209 IF (.not.allocated(ig_aux)) THEN 00210 ALLOCATE (ig_aux(ig_nbr_rstfile), stat=il_err) 00211 IF (il_ERR.ne.0) & 00212 WRITE(nulprt,*)'Error in "ig_aux" allocation in write_filer8 routine ! ' 00213 ig_aux(:) = 0 00214 ENDIF 00215 il_unit = nulprt + 1 00216 INQUIRE (il_unit,OPENED = ll_file) 00217 DO WHILE (ll_file) 00218 il_unit = il_unit + 1 00219 INQUIRE (il_unit,OPENED = ll_file) 00220 END DO 00221 il_nolocal = ig_def_norstfile(id_port) 00222 ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1 00223 IF (ig_aux(il_nolocal).eq.1) THEN 00224 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00225 FORM='UNFORMATTED') 00226 ELSE 00227 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00228 position='append', FORM='UNFORMATTED') 00229 ENDIF 00230 CALL locwriter8(cd_port,out_fld,myport(4,id_port),il_unit, & 00231 ierror, nulprt) 00232 CLOSE (il_unit) 00233 #ifdef use_netCDF 00234 ENDIF 00235 #endif 00236 #ifdef __VERBOSE 00237 WRITE(nulprt,*)'| | | Leaving write_filer8 ' 00238 WRITE(nulprt,*)' ' 00239 CALL FLUSH(nulprt) 00240 #endif 00241 END SUBROUTINE write_filer8 00242 ! ******************************************************************** 00243 ! ******************************************************************** 00244 ! ******************************************************************** 00245 ! 00246 !* *** WRITE_FILE_PARAR4*** PRISM 1.0 00247 ! 00248 ! purpose: 00249 ! -------- 00250 ! At first time step, write fields to binary files or netcdf files. 00251 ! 00252 ! interface: 00253 ! ---------- 00254 ! out_fld : field to be read from the restart file 00255 ! cd_port : symbolic name of the field 00256 ! id_port : port number of the field 00257 ! 00258 ! lib mp: 00259 ! ------- 00260 ! mpi-1 00261 ! 00262 ! author: 00263 ! ------- 00264 ! Eric Sevault - METEO FRANCE 00265 ! Laurent Terray - CERFACS 00266 ! Jean Latour - F.S.E. (mpi-2) 00267 ! Arnaud Caubel - Adaptation to PRISM interface 00268 ! ---------------------------------------------------------------- 00269 SUBROUTINE write_file_parar4(out_fld, cd_port,id_port) 00270 ! ---------------------------------------------------------------- 00271 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 00272 USE mod_kinds_model 00273 USE mod_prism_proto 00274 USE mod_comprism_proto 00275 IMPLICIT NONE 00276 #ifdef use_netCDF 00277 #include <netcdf.inc> 00278 #endif 00279 #include <mpif.h> 00280 ! ---------------------------------------------------------------- 00281 CHARACTER(len=8), intent(in) :: cd_port 00282 INTEGER (kind=ip_intwp_p), intent(in) :: id_port 00283 REAL(kind=ip_single_p), intent(in) :: out_fld(myport(4,id_port)) 00284 ! ---------------------------------------------------------------- 00285 INTEGER (kind=ip_intwp_p),PARAMETER :: ip_tag=100 00286 INTEGER (kind=ip_intwp_p) il_unit, il_nolocal, il_len, il_aux 00287 INTEGER (kind=ip_intwp_p) ierror, il_varid, il_ncid, il_status_ncdf 00288 INTEGER (kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_rank, iposbuf, il_off 00289 INTEGER (kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus 00290 INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast 00291 REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_end, rl_work 00292 REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast 00293 LOGICAL ll_file 00294 INTEGER(kind=ip_intwp_p)::il_sndreq 00295 ! ---------------------------------------------------------------- 00296 #ifdef __VERBOSE 00297 WRITE(nulprt,*)' ' 00298 WRITE(nulprt,*)'| | | Entering write_parar4 ' 00299 CALL FLUSH(nulprt) 00300 #endif 00301 ! 00302 !* Each process of local communicator sends his decomposition to master proc 00303 ! 00304 IF (mpi_rank .NE. 0) THEN 00305 CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, & 00306 ip_tag, ig_local_comm, ierror ) 00307 CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, & 00308 ip_tag+1, ig_local_comm, ierror ) 00309 ENDIF 00310 ! 00311 !* Master proc receives each process decomposition 00312 ! 00313 IF (mpi_rank.eq.0) THEN 00314 il_maxgrd = 0 00315 ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod))) 00316 il_paral_mast(:,:)=0 00317 ! 00318 !* Master only copies to prevent deadlock 00319 ! 00320 il_paral_mast(:,1) = mydist(:,id_port) 00321 il_aux = myport(4,id_port) 00322 il_maxgrd = il_maxgrd + il_aux 00323 ! 00324 DO ib = 1, kbcplproc(ig_mynummod)-1 00325 CALL MPI_Recv (il_paral_mast(:,ib+1), & 00326 CLIM_Parsize, MPI_INTEGER, ib, & 00327 ip_tag, ig_local_comm, istatus, ierror ) 00328 CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, & 00329 ip_tag+1, ig_local_comm, istatus, ierror ) 00330 il_maxgrd = il_maxgrd + il_aux 00331 END DO 00332 il_maxbyte = il_maxgrd * 4 00333 ENDIF 00334 ! 00335 !* Each process sends hid part of the field to Master process 00336 ! 00337 ALLOCATE(rl_work(myport(4,id_port))) 00338 rl_work(:) = 0 00339 iposbuf = 0 00340 il_off=1 00341 il_len=myport(4,id_port) 00342 call MPI_Pack(out_fld(il_off:il_off+il_len-1), & 00343 il_len,MPI_REAL,rl_work, & 00344 myport(4,id_port)*4,iposbuf,ig_local_comm,ierror) 00345 if(mpi_rank.gt.0)then 00346 CALL MPI_Send ( rl_work, iposbuf, MPI_PACKED, 0, & 00347 ip_tag+2, ig_local_comm, ierror ) 00348 else 00349 CALL MPI_ISend ( rl_work, iposbuf, MPI_PACKED, 0, & 00350 ip_tag+2, ig_local_comm, il_sndreq, ierror ) 00351 endif 00352 ! 00353 !* Master process receives the part of the field from each process and writes 00354 ! the entire field to restart file 00355 ! 00356 IF (mpi_rank.eq.0) THEN 00357 ALLOCATE(rl_work_mast(il_maxgrd)) 00358 ALLOCATE (rl_end(il_maxgrd)) 00359 rl_work_mast(:)=0 00360 rl_end(:)=0 00361 DO ib_rank = 0, kbcplproc(ig_mynummod) - 1 00362 CALL MPI_Recv ( rl_work_mast, il_maxbyte, MPI_PACKED, ib_rank , & 00363 ip_tag+2, ig_local_comm, istatus, ierror ) 00364 iposbuf=0 00365 DO ib=1,il_paral_mast(clim_segments,ib_rank+1) 00366 il_off=il_paral_mast(clim_segments+2*ib-1,ib_rank+1)+1 00367 il_len=il_paral_mast(clim_segments+2*ib,ib_rank+1) 00368 CALL MPI_Unpack(rl_work_mast, il_maxbyte, iposbuf, & 00369 rl_end(il_off:il_off+il_len-1),il_len, & 00370 MPI_REAL, ig_local_comm, ierror) 00371 END DO 00372 END DO 00373 CALL mpi_wait(il_sndreq,istatus,ierror) 00374 DEALLOCATE (rl_work_mast) 00375 DEALLOCATE (il_paral_mast) 00376 ! 00377 !* Test if restart file is in NETCDF format or not 00378 ! 00379 #ifdef use_netCDF 00380 IF (lg_ncdfrst) THEN 00381 ! 00382 !* Case NETCDF format 00383 ! 00384 il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port), & 00385 NF_WRITE,il_ncid) 00386 IF (il_status_ncdf.ne.NF_NOERR) THEN 00387 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00388 WRITE(nulprt,*)' stop in write_parar4 routine 1' 00389 call MPI_ABORT (mpi_comm, 0, mpi_err) 00390 ENDIF 00391 il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid) 00392 IF (il_status_ncdf.ne.NF_NOERR) THEN 00393 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00394 WRITE(nulprt,*)' stop in write_parar4routine 2' 00395 call MPI_ABORT (mpi_comm, 0, mpi_err) 00396 ENDIF 00397 il_status_ncdf = NF_PUT_VAR_REAL (il_ncid, il_varid, & 00398 rl_end) 00399 IF (il_status_ncdf.ne.NF_NOERR) THEN 00400 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00401 WRITE(nulprt,*)' stop in write_parar4 routine 3' 00402 call MPI_ABORT (mpi_comm, 0, mpi_err) 00403 ENDIF 00404 il_status_ncdf = NF_CLOSE(il_ncid) 00405 IF (il_status_ncdf.ne.NF_NOERR) THEN 00406 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00407 WRITE(nulprt,*)' stop in write_parar4 routine 4' 00408 call MPI_ABORT (mpi_comm, 0, mpi_err) 00409 ENDIF 00410 ELSE 00411 #endif 00412 ! 00413 !* Case binary format 00414 ! 00415 IF (.not.allocated(ig_aux)) THEN 00416 ALLOCATE (ig_aux(ig_nbr_rstfile), stat=ierror) 00417 IF (ierror.ne.0) & 00418 WRITE(nulprt,*)'Error in "ig_aux" allocation in write_parar4 routine ! ' 00419 ig_aux(:) = 0 00420 ENDIF 00421 il_unit = nulprt + 1 00422 INQUIRE (il_unit,OPENED = ll_file) 00423 DO WHILE (ll_file) 00424 il_unit = il_unit + 1 00425 INQUIRE (il_unit,OPENED = ll_file) 00426 END DO 00427 il_nolocal = ig_def_norstfile(id_port) 00428 ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1 00429 IF (ig_aux(il_nolocal).eq.1) THEN 00430 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00431 FORM='UNFORMATTED') 00432 ELSE 00433 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00434 position='append', FORM='UNFORMATTED') 00435 ENDIF 00436 CALL locwriter4(cd_port,rl_end, il_maxgrd, & 00437 il_unit, ierror, nulprt) 00438 CLOSE (il_unit) 00439 ENDIF 00440 DEALLOCATE(rl_end) 00441 #ifdef use_netCDF 00442 ENDIF 00443 #endif 00444 #endif 00445 #ifdef __VERBOSE 00446 WRITE(nulprt,*)'| | | Leaving write_parar4 ' 00447 WRITE(nulprt,*)' ' 00448 CALL FLUSH(nulprt) 00449 #endif 00450 END SUBROUTINE write_file_parar4 00451 00452 ! ******************************************************************** 00453 ! ******************************************************************** 00454 ! ******************************************************************** 00455 ! 00456 !* *** WRITE_FILE_PARAR8*** PRISM 1.0 00457 ! 00458 ! purpose: 00459 ! -------- 00460 ! At first time step, write fields to binary files or netcdf files. 00461 ! 00462 ! interface: 00463 ! ---------- 00464 ! out_fld : field to be read from the restart file 00465 ! cd_port : symbolic name of the field 00466 ! id_port : port number of the field 00467 ! 00468 ! lib mp: 00469 ! ------- 00470 ! mpi-1 00471 ! 00472 ! author: 00473 ! ------- 00474 ! Eric Sevault - METEO FRANCE 00475 ! Laurent Terray - CERFACS 00476 ! Jean Latour - F.S.E. (mpi-2) 00477 ! Arnaud Caubel - Adaptation to PRISM interface 00478 ! ---------------------------------------------------------------- 00479 SUBROUTINE write_file_parar8(out_fld, cd_port,id_port) 00480 ! ---------------------------------------------------------------- 00481 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 00482 USE mod_kinds_model 00483 USE mod_prism_proto 00484 USE mod_comprism_proto 00485 IMPLICIT NONE 00486 #ifdef use_netCDF 00487 #include <netcdf.inc> 00488 #endif 00489 #include <mpif.h> 00490 ! ---------------------------------------------------------------- 00491 CHARACTER(len=8), intent(in) :: cd_port 00492 INTEGER (kind=ip_intwp_p), intent(in) :: id_port 00493 REAL(kind=ip_double_p), intent(in) :: out_fld(myport(4,id_port)) 00494 ! ---------------------------------------------------------------- 00495 INTEGER (kind=ip_intwp_p),PARAMETER :: ip_tag=100 00496 INTEGER (kind=ip_intwp_p) il_unit, il_nolocal, il_len, il_aux 00497 INTEGER (kind=ip_intwp_p) ierror, il_varid, il_ncid, il_status_ncdf 00498 INTEGER (kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_rank, iposbuf, il_off 00499 INTEGER (kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus 00500 INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast 00501 REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_end, rl_work 00502 REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast 00503 LOGICAL ll_file 00504 integer(kind=ip_intwp_p)::il_sndreq 00505 ! ---------------------------------------------------------------- 00506 #ifdef __VERBOSE 00507 WRITE(nulprt,*)' ' 00508 WRITE(nulprt,*)'| | | Entering write_parar8 ' 00509 CALL FLUSH(nulprt) 00510 #endif 00511 ! 00512 !* Each process of local communicator sends his decomposition to master proc 00513 ! 00514 IF (mpi_rank .NE. 0) THEN 00515 CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, & 00516 ip_tag, ig_local_comm, ierror ) 00517 CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, & 00518 ip_tag+1, ig_local_comm, ierror ) 00519 ENDIF 00520 ! 00521 !* Master proc receives each process decomposition 00522 ! 00523 IF (mpi_rank.eq.0) THEN 00524 il_maxgrd = 0 00525 ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod))) 00526 il_paral_mast(:,:)=0 00527 ! 00528 !* Master only copies to prevent deadlock 00529 ! 00530 il_paral_mast(:,1) = mydist(:,id_port) 00531 il_aux = myport(4,id_port) 00532 il_maxgrd = il_maxgrd + il_aux 00533 ! 00534 DO ib = 1, kbcplproc(ig_mynummod)-1 00535 CALL MPI_Recv (il_paral_mast(:,ib+1), & 00536 CLIM_Parsize, MPI_INTEGER, ib, & 00537 ip_tag, ig_local_comm, istatus, ierror ) 00538 CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, & 00539 ip_tag+1, ig_local_comm, istatus, ierror ) 00540 il_maxgrd = il_maxgrd + il_aux 00541 END DO 00542 il_maxbyte = il_maxgrd * 8 00543 ENDIF 00544 ! 00545 !* Each process sends hid part of the field to Master process 00546 ! 00547 ALLOCATE(rl_work(myport(4,id_port))) 00548 rl_work(:) = 0 00549 iposbuf = 0 00550 il_off=1 00551 il_len=myport(4,id_port) 00552 call MPI_Pack(out_fld(il_off:il_off+il_len-1), & 00553 il_len,MPI_DOUBLE_PRECISION,rl_work, & 00554 myport(4,id_port)*8,iposbuf,ig_local_comm,ierror) 00555 if(mpi_rank.gt.0)then 00556 CALL MPI_Send ( rl_work, iposbuf, MPI_PACKED, 0, & 00557 ip_tag+2, ig_local_comm, ierror ) 00558 else 00559 CALL MPI_ISend ( rl_work, iposbuf, MPI_PACKED, 0, & 00560 ip_tag+2, ig_local_comm, il_sndreq, ierror ) 00561 endif 00562 ! 00563 !* Master process receives the part of the field from each process and writes 00564 ! the entire field to restart file 00565 ! 00566 IF (mpi_rank.eq.0) THEN 00567 ALLOCATE(rl_work_mast(il_maxgrd)) 00568 ALLOCATE (rl_end(il_maxgrd)) 00569 rl_work_mast(:)=0 00570 rl_end(:)=0 00571 DO ib_rank = 0, kbcplproc(ig_mynummod) - 1 00572 CALL MPI_Recv ( rl_work_mast, il_maxbyte, MPI_PACKED, ib_rank , & 00573 ip_tag+2, ig_local_comm, istatus, ierror ) 00574 iposbuf=0 00575 DO ib=1,il_paral_mast(clim_segments,ib_rank+1) 00576 il_off=il_paral_mast(clim_segments+2*ib-1,ib_rank+1)+1 00577 il_len=il_paral_mast(clim_segments+2*ib,ib_rank+1) 00578 CALL MPI_Unpack(rl_work_mast, il_maxbyte, iposbuf, & 00579 rl_end(il_off:il_off+il_len-1),il_len, & 00580 MPI_DOUBLE_PRECISION, ig_local_comm, ierror) 00581 END DO 00582 END DO 00583 call mpi_wait(il_sndreq,istatus,ierror) 00584 DEALLOCATE (rl_work_mast) 00585 DEALLOCATE (il_paral_mast) 00586 ! 00587 !* Test if restart file is in NETCDF format or not 00588 ! 00589 #ifdef use_netCDF 00590 IF (lg_ncdfrst) THEN 00591 ! 00592 !* Case NETCDF format 00593 ! 00594 il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port), & 00595 NF_WRITE,il_ncid) 00596 IF (il_status_ncdf.ne.NF_NOERR) THEN 00597 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00598 WRITE(nulprt,*)' stop in write_parar8 routine 1' 00599 call MPI_ABORT (mpi_comm, 0, mpi_err) 00600 ENDIF 00601 il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid) 00602 IF (il_status_ncdf.ne.NF_NOERR) THEN 00603 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00604 WRITE(nulprt,*)' stop in write_parar8 routine 2' 00605 call MPI_ABORT (mpi_comm, 0, mpi_err) 00606 ENDIF 00607 il_status_ncdf = NF_PUT_VAR_DOUBLE (il_ncid, il_varid, rl_end) 00608 IF (il_status_ncdf.ne.NF_NOERR) THEN 00609 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00610 WRITE(nulprt,*)' stop in write_parar8 routine 3' 00611 call MPI_ABORT (mpi_comm, 0, mpi_err) 00612 ENDIF 00613 il_status_ncdf = NF_CLOSE(il_ncid) 00614 IF (il_status_ncdf.ne.NF_NOERR) THEN 00615 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 00616 WRITE(nulprt,*)' stop in write_parar8 routine 4' 00617 call MPI_ABORT (mpi_comm, 0, mpi_err) 00618 ENDIF 00619 ELSE 00620 #endif 00621 ! 00622 !* Case binary format 00623 ! 00624 IF (.not.allocated(ig_aux)) THEN 00625 ALLOCATE (ig_aux(ig_nbr_rstfile), stat=ierror) 00626 IF (ierror.ne.0) & 00627 WRITE(nulprt,*)'Error in "ig_aux" allocation in write_parar8 routine ! ' 00628 ig_aux(:) = 0 00629 ENDIF 00630 il_unit = nulprt + 1 00631 INQUIRE (il_unit,OPENED = ll_file) 00632 DO WHILE (ll_file) 00633 il_unit = il_unit + 1 00634 INQUIRE (il_unit,OPENED = ll_file) 00635 END DO 00636 il_nolocal = ig_def_norstfile(id_port) 00637 ig_aux(il_nolocal) = ig_aux(il_nolocal) + 1 00638 IF (ig_aux(il_nolocal).eq.1) THEN 00639 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00640 FORM='UNFORMATTED') 00641 ELSE 00642 OPEN (il_unit, FILE=cg_def_rstfile(id_port), & 00643 position='append', FORM='UNFORMATTED') 00644 ENDIF 00645 CALL locwriter8(cd_port,rl_end, il_maxgrd, & 00646 il_unit, ierror, nulprt) 00647 CLOSE (il_unit) 00648 ENDIF 00649 DEALLOCATE(rl_end) 00650 #ifdef use_netCDF 00651 ENDIF 00652 #endif 00653 #endif 00654 #ifdef __VERBOSE 00655 WRITE(nulprt,*)'| | | Leaving write_parar8 ' 00656 WRITE(nulprt,*)' ' 00657 CALL FLUSH(nulprt) 00658 #endif 00659 END SUBROUTINE write_file_parar8 00660 00661 ! ******************************************************************** 00662 ! ******************************************************************** 00663 ! ******************************************************************** 00664 ! 00665 SUBROUTINE locwriter4 (cdfldn, pfield, kdimax, knulre, kflgre, kout) 00666 USE mod_kinds_model 00667 IMPLICIT none 00668 ! 00669 !**** *LOCWRITER4* - Write binary field on unit knulre 00670 ! 00671 ! Purpose: 00672 ! ------- 00673 ! Write string cdfldn and array pfield on unit knulre 00674 ! 00675 !** Interface: 00676 ! --------- 00677 ! *CALL* *locwrite (cdfldn, pfield, kdimax, knulre, kflgre, kout)* 00678 ! 00679 ! Input: 00680 ! ----- 00681 ! cdfldn : character string locator 00682 ! kdimax : dimension of field to be written 00683 ! knulre : logical unit to be written 00684 ! pfield : field array (real 1D) 00685 ! kout : logical unit to write messages 00686 ! 00687 ! Output: 00688 ! ------ 00689 ! kflgre : error status flag 00690 ! 00691 ! Workspace: 00692 ! --------- 00693 ! None 00694 ! 00695 ! Externals: 00696 ! --------- 00697 ! None 00698 ! 00699 ! Reference: 00700 ! --------- 00701 ! See OASIS manual (1995) 00702 ! 00703 ! History: 00704 ! ------- 00705 ! Version Programmer Date Description 00706 ! ------- ---------- ---- ----------- 00707 ! 2.0 L. Terray 95/09/01 created 00708 ! 00709 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00710 ! 00711 ! 00712 !* ---------------------------- Argument declarations ------------------- 00713 ! 00714 INTEGER (kind=ip_intwp_p) kdimax, knulre, kflgre, kout 00715 REAL(kind=ip_single_p) :: pfield(kdimax) 00716 CHARACTER*8 cdfldn 00717 ! 00718 !* ---------------------------- Poema verses ---------------------------- 00719 ! 00720 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00721 ! 00722 !* 1. Initialization 00723 ! -------------- 00724 ! 00725 WRITE (UNIT = kout,FMT = 1001) knulre 00726 ! 00727 !* Formats 00728 ! 00729 1001 FORMAT(5X,' Write binary file connected to unit = ',I4) 00730 ! 00731 ! 2. Find field in file 00732 ! ------------------ 00733 ! 00734 !* Write string 00735 WRITE (UNIT = knulre, ERR = 210) cdfldn 00736 !* Write associated field 00737 WRITE (UNIT = knulre, ERR = 210) pfield 00738 !* Writing done and ok 00739 kflgre = 0 00740 GO TO 220 00741 !* Problem in Writing 00742 210 kflgre = 1 00743 220 CONTINUE 00744 ! 00745 ! 00746 !* 3. End of routine 00747 ! -------------- 00748 ! 00749 WRITE (UNIT = kout,FMT = *) 'Locwrite : done' 00750 CALL FLUSH (kout) 00751 RETURN 00752 END SUBROUTINE locwriter4 00753 00754 ! ******************************************************************** 00755 ! ******************************************************************** 00756 ! ******************************************************************** 00757 ! 00758 SUBROUTINE locwriter8 (cdfldn, pfield, kdimax, knulre, kflgre, kout) 00759 USE mod_kinds_model 00760 IMPLICIT none 00761 ! 00762 !**** *LOCWRITER8* - Write binary field on unit knulre 00763 ! 00764 ! Purpose: 00765 ! ------- 00766 ! Write string cdfldn and array pfield on unit knulre 00767 ! 00768 !** Interface: 00769 ! --------- 00770 ! *CALL* *locwrite (cdfldn, pfield, kdimax, knulre, kflgre, kout)* 00771 ! 00772 ! Input: 00773 ! ----- 00774 ! cdfldn : character string locator 00775 ! kdimax : dimension of field to be written 00776 ! knulre : logical unit to be written 00777 ! pfield : field array (real 1D) 00778 ! kout : logical unit to write messages 00779 ! 00780 ! Output: 00781 ! ------ 00782 ! kflgre : error status flag 00783 ! 00784 ! Workspace: 00785 ! --------- 00786 ! None 00787 ! 00788 ! Externals: 00789 ! --------- 00790 ! None 00791 ! 00792 ! Reference: 00793 ! --------- 00794 ! See OASIS manual (1995) 00795 ! 00796 ! History: 00797 ! ------- 00798 ! Version Programmer Date Description 00799 ! ------- ---------- ---- ----------- 00800 ! 2.0 L. Terray 95/09/01 created 00801 ! 00802 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00803 ! 00804 ! 00805 !* ---------------------------- Argument declarations ------------------- 00806 ! 00807 INTEGER (kind=ip_intwp_p) kdimax, knulre, kflgre, kout 00808 REAL(kind=ip_double_p) :: pfield(kdimax) 00809 CHARACTER*8 cdfldn 00810 ! 00811 !* ---------------------------- Poema verses ---------------------------- 00812 ! 00813 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 00814 ! 00815 !* 1. Initialization 00816 ! -------------- 00817 ! 00818 WRITE (UNIT = kout,FMT = 1001) knulre 00819 ! 00820 !* Formats 00821 ! 00822 1001 FORMAT(5X,' Write binary file connected to unit = ',I4) 00823 ! 00824 ! 2. Find field in file 00825 ! ------------------ 00826 ! 00827 !* Write string 00828 WRITE (UNIT = knulre, ERR = 210) cdfldn 00829 !* Write associated field 00830 WRITE (UNIT = knulre, ERR = 210) pfield 00831 !* Writing done and ok 00832 kflgre = 0 00833 GO TO 220 00834 !* Problem in Writing 00835 210 kflgre = 1 00836 220 CONTINUE 00837 ! 00838 ! 00839 !* 3. End of routine 00840 ! -------------- 00841 ! 00842 WRITE (UNIT = kout,FMT = *) 'Locwrite : done' 00843 CALL FLUSH (kout) 00844 RETURN 00845 END SUBROUTINE locwriter8
1.7.4 
