|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
00001 !----------------------------------------------------------------------- 00002 ! BOP 00003 ! 00004 ! !MODULE: mod_prism_grids_writing 00005 ! !REMARKS: 00006 ! !REVISION HISTORY: 00007 ! 2003.07.07 Veronika Gayler initial version 00008 ! 00009 ! !PUBLIC MEMBER FUNCTIONS: 00010 ! 00011 ! subroutine prism_start_grids_writing(iwrite) 00012 ! This subroutine initializes grids writing by receiving a 00013 ! starting command from OASIS. 00014 ! 00015 ! subroutine prism_write_grid(cgrid, nx, ny, lon, lat) 00016 ! This subroutine writes longitudes and latitudes for a model 00017 ! grid. 00018 ! 00019 ! subroutine prism_write_corner(cgrid, nx, ny, nc, clon, clat) 00020 ! This subroutine writes the longitudes and latitudes of the 00021 ! grid cell corners. 00022 ! 00023 ! subroutine prism_write_mask(cgrid, nx, ny, mask) 00024 ! This subroutine writes the mask for a model grid 00025 ! 00026 ! subroutine prism_write_area(cgrid, nx, ny, area) 00027 ! This subroutine writes the grid cell areas for a model grid. 00028 ! 00029 ! subroutine prism_terminate_grids_writing() 00030 ! This subroutine terminates grids writing by sending a flag 00031 ! to OASIS, stating the all needed grid information was written. 00032 ! 00033 00034 MODULE mod_prism_grids_writing 00035 00036 ! !USES: 00037 USE mod_comprism_proto 00038 00039 IMPLICIT NONE 00040 #if defined use_comm_MPI1 || defined use_comm_MPI2 00041 #include <mpif.h> 00042 #endif 00043 INTEGER(kind=ip_intwp_p), PARAMETER :: itagcol=9876 00044 INTEGER(kind=ip_intwp_p) :: tag ! MPI message tag 00045 INTEGER(kind=ip_intwp_p) :: len ! MPI message length 00046 INTEGER(kind=ip_intwp_p) :: type ! MPI message type 00047 LOGICAL :: gridswrite ! grid writing is needed 00048 LOGICAL :: l_netcdf ! grids file format is netCDF 00049 CHARACTER*5 :: cgrdnam ! grids file name 00050 CHARACTER*5 :: cmsknam ! masks file name 00051 CHARACTER*5 :: csurnam ! areas file name 00052 CHARACTER*4 :: cglonsuf ! suffix for longitudes 00053 CHARACTER*4 :: cglatsuf ! suffix for latitudes 00054 CHARACTER*4 :: crnlonsuf ! suffix for longitudes 00055 CHARACTER*4 :: crnlatsuf ! suffix for latitudes 00056 CHARACTER*4 :: cmsksuf ! suffix for masks 00057 CHARACTER*4 :: csursuf ! suffix for areas 00058 CHARACTER*4 :: cangsuf ! suffix for angles 00059 !--------------------------------------------------------------------------- 00060 00061 CONTAINS 00062 00063 !-------------------------------------------------------------------------- 00064 ! 00065 SUBROUTINE prism_start_grids_writing(iwrite) 00066 !-------------------------------------------------------------------------- 00067 ! Routine to start the grids writing. To syncronize access to the 00068 ! grids file all component models have to wait for the starting 00069 ! message from OASIS (via MPI; see prism_init_comp_proto) 00070 !-------------------------------------------------------------------------- 00071 #if defined use_comm_GSIP 00072 USE mod_gsip_model 00073 #endif 00074 IMPLICIT NONE 00075 00076 INTEGER(kind=ip_intwp_p), INTENT (OUT) :: iwrite ! flag to state whether 00077 ! grids file needs to be written 00078 INTEGER(kind=ip_intwp_p) :: source ! rank of the sending process 00079 #if defined use_comm_MPI1 || defined use_comm_MPI2 00080 INTEGER(kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: status 00081 #elif defined use_comm_GSIP 00082 INTEGER :: mgi_write, mgi_read 00083 INTEGER :: il_errgsip 00084 CHARACTER*8, DIMENSION(9) :: cla_work 00085 #endif 00086 !-------------------------------------------------------------------------- 00087 00088 #ifdef __VERBOSE 00089 write(nulprt,*) ' ' 00090 write(nulprt,*) '| | | Entering - - prism_start_grids_writing' 00091 call flush(nulprt) 00092 #endif 00093 ! 00094 !-- Initialisation 00095 ! 00096 #ifdef use_netCDF 00097 l_netcdf = .true. 00098 #else 00099 l_netcdf = .false. 00100 #endif 00101 gridswrite = .false. 00102 iwrite = 0 00103 cgrdnam = '-----' 00104 cmsknam = '-----' 00105 csurnam = '-----' 00106 cglonsuf = '----' 00107 cglatsuf = '----' 00108 crnlonsuf = '----' 00109 crnlatsuf = '----' 00110 cmsksuf = '----' 00111 csursuf = '----' 00112 cangsuf = '----' 00113 source = 0 ! OASIS: process 0 of global communicator 00114 00115 IF (grids_start == 1) THEN 00116 gridswrite = .true. 00117 ! 00118 !-- receive grid file name 00119 ! 00120 #if defined use_comm_MPI1 || defined use_comm_MPI2 00121 #ifdef __VERBOSE 00122 WRITE (nulprt,FMT='(A)') 'Recv - cgrdnam' 00123 call flush(nulprt) 00124 #endif 00125 len = 5 00126 type = MPI_CHARACTER 00127 tag = itagcol+4 00128 CALL MPI_Recv (cgrdnam, len, type, source, tag, mpi_comm, status,mpi_err) 00129 IF (mpi_err == MPI_SUCCESS) THEN 00130 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)') & 00131 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00132 '> <type:',type,'> <tag:',tag,'> :: ',cgrdnam 00133 ELSE 00134 WRITE (nulprt,*) ' ' 00135 WRITE (nulprt,*) 'start_grids_writing: error receiving cgrdnam' 00136 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00137 WRITE (nulprt,*) 'start_grids_writing: STOP' 00138 STOP 00139 ENDIF 00140 ! 00141 !-- receive mask file name 00142 ! 00143 #ifdef __VERBOSE 00144 WRITE (nulprt,FMT='(A)') 'Recv - cmsknam' 00145 call flush(nulprt) 00146 #endif 00147 len = 5 00148 type = MPI_CHARACTER 00149 tag = itagcol+5 00150 CALL MPI_Recv (cmsknam, len, type, source, tag, mpi_comm, status,mpi_err) 00151 IF (mpi_err == MPI_SUCCESS) THEN 00152 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)') & 00153 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00154 '> <type:',type,'> <tag:',tag,'> :: ',cmsknam 00155 ELSE 00156 WRITE (nulprt,*) ' ' 00157 WRITE (nulprt,*) 'start_grids_writing: error receiving cmsknam' 00158 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00159 WRITE (nulprt,*) 'start_grids_writing: STOP' 00160 STOP 00161 ENDIF 00162 ! 00163 !-- receive areas file name 00164 ! 00165 #ifdef __VERBOSE 00166 WRITE (nulprt,FMT='(A)') 'Recv - csurnam' 00167 call flush(nulprt) 00168 #endif 00169 len = 5 00170 type = MPI_CHARACTER 00171 tag = itagcol+6 00172 CALL MPI_Recv (csurnam, len, type, source, tag, mpi_comm, status,mpi_err) 00173 IF (mpi_err == MPI_SUCCESS) THEN 00174 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A5)') & 00175 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00176 '> <type:',type,'> <tag:',tag,'> :: ',csurnam 00177 ELSE 00178 WRITE (nulprt,*) ' ' 00179 WRITE (nulprt,*) 'start_grids_writing: error receiving csurnam' 00180 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00181 WRITE (nulprt,*) 'start_grids_writing: STOP' 00182 STOP 00183 ENDIF 00184 ! 00185 !-- receive suffix for longitudes 00186 ! 00187 #ifdef __VERBOSE 00188 WRITE (nulprt,FMT='(A)') 'Recv - cglonsuf' 00189 call flush(nulprt) 00190 #endif 00191 len = 4 00192 type = MPI_CHARACTER 00193 tag = itagcol+7 00194 CALL MPI_Recv (cglonsuf, len, type, source, tag, mpi_comm,status,mpi_err) 00195 IF (mpi_err == MPI_SUCCESS) THEN 00196 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') & 00197 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00198 '> <type:',type,'> <tag:',tag,'> :: ',cglonsuf 00199 ELSE 00200 WRITE (nulprt,*) ' ' 00201 WRITE (nulprt,*) 'start_grids_writing: error receiving cglonsuf' 00202 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00203 WRITE (nulprt,*) 'start_grids_writing: STOP' 00204 STOP 00205 ENDIF 00206 ! 00207 !-- receive suffix for latitudes 00208 ! 00209 #ifdef __VERBOSE 00210 WRITE (nulprt,FMT='(A)') 'Recv - cglatsuf' 00211 call flush(nulprt) 00212 #endif 00213 len = 4 00214 type = MPI_CHARACTER 00215 tag = itagcol+8 00216 CALL MPI_Recv (cglatsuf, len, type, source, tag, mpi_comm,status,mpi_err) 00217 IF (mpi_err == MPI_SUCCESS) THEN 00218 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') & 00219 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00220 '> <type:',type,'> <tag:',tag,'> :: ',cglatsuf 00221 ELSE 00222 WRITE (nulprt,*) ' ' 00223 WRITE (nulprt,*) 'start_grids_writing: error receiving cglatsuf' 00224 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00225 WRITE (nulprt,*) 'start_grids_writing: STOP' 00226 STOP 00227 ENDIF 00228 ! 00229 !-- receive suffix for longitudes of grid cell corners 00230 ! 00231 #ifdef __VERBOSE 00232 WRITE (nulprt,FMT='(A)') 'Recv - crnlonsuf' 00233 call flush(nulprt) 00234 #endif 00235 len = 4 00236 type = MPI_CHARACTER 00237 tag = itagcol+9 00238 CALL MPI_Recv (crnlonsuf, len, type, source, tag, mpi_comm,status,mpi_err) 00239 IF (mpi_err == MPI_SUCCESS) THEN 00240 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') & 00241 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00242 '> <type:',type,'> <tag:',tag,'> :: ',crnlonsuf 00243 ELSE 00244 WRITE (nulprt,*) ' ' 00245 WRITE (nulprt,*) 'start_grids_writing: error receiving crnlonsuf' 00246 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00247 WRITE (nulprt,*) 'start_grids_writing: STOP' 00248 STOP 00249 ENDIF 00250 ! 00251 !-- receive suffix for latitudes of grid cell corners 00252 ! 00253 #ifdef __VERBOSE 00254 WRITE (nulprt,FMT='(A)') 'Recv - crnlatsuf' 00255 call flush(nulprt) 00256 #endif 00257 len = 4 00258 type = MPI_CHARACTER 00259 tag = itagcol+10 00260 CALL MPI_Recv (crnlatsuf, len, type, source, tag, mpi_comm,status,mpi_err) 00261 IF (mpi_err == MPI_SUCCESS) THEN 00262 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') & 00263 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00264 '> <type:',type,'> <tag:',tag,'> :: ',crnlatsuf 00265 ELSE 00266 WRITE (nulprt,*) ' ' 00267 WRITE (nulprt,*) 'start_grids_writing: error receiving crnlatsuf' 00268 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00269 WRITE (nulprt,*) 'start_grids_writing: STOP' 00270 STOP 00271 ENDIF 00272 ! 00273 !-- receive suffix for masks 00274 ! 00275 #ifdef __VERBOSE 00276 WRITE (nulprt,FMT='(A)') 'Recv - cmsksuf' 00277 call flush(nulprt) 00278 #endif 00279 len = 4 00280 type = MPI_CHARACTER 00281 tag = itagcol+11 00282 CALL MPI_Recv (cmsksuf, len, type, source, tag, mpi_comm, status,mpi_err) 00283 IF (mpi_err == MPI_SUCCESS) THEN 00284 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') & 00285 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00286 '> <type:',type,'> <tag:',tag,'> :: ',cmsksuf 00287 ELSE 00288 WRITE (nulprt,*) ' ' 00289 WRITE (nulprt,*) 'start_grids_writing: error receiving cmsksuf' 00290 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00291 WRITE (nulprt,*) 'start_grids_writing: STOP' 00292 STOP 00293 ENDIF 00294 ! 00295 !-- receive suffix for areas 00296 ! 00297 #ifdef __VERBOSE 00298 WRITE (nulprt,FMT='(A)') 'Recv - csursuf' 00299 call flush(nulprt) 00300 #endif 00301 len = 4 00302 type = MPI_CHARACTER 00303 tag = itagcol+12 00304 CALL MPI_Recv (csursuf, len, type, source, tag, mpi_comm, status,mpi_err) 00305 IF (mpi_err == MPI_SUCCESS) THEN 00306 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') & 00307 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00308 '> <type:',type,'> <tag:',tag,'> :: ',csursuf 00309 ELSE 00310 WRITE (nulprt,*) ' ' 00311 WRITE (nulprt,*) 'start_grids_writing: error receiving csursuf' 00312 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00313 WRITE (nulprt,*) 'start_grids_writing: STOP' 00314 STOP 00315 ENDIF 00316 ! 00317 !-- receive suffix for angles 00318 ! 00319 #ifdef __VERBOSE 00320 WRITE (nulprt,FMT='(A)') 'Recv - cangsuf' 00321 call flush(nulprt) 00322 #endif 00323 len = 4 00324 type = MPI_CHARACTER 00325 tag = itagcol+12 00326 CALL MPI_Recv (cangsuf, len, type, source, tag, mpi_comm, status,mpi_err) 00327 IF (mpi_err == MPI_SUCCESS) THEN 00328 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,A4)') & 00329 'Recv - <from:',source,'> <comm:',mpi_comm,'> <len:',len, & 00330 '> <type:',type,'> <tag:',tag,'> :: ',cangsuf 00331 ELSE 00332 WRITE (nulprt,*) ' ' 00333 WRITE (nulprt,*) 'start_grids_writing: error receiving cangsuf' 00334 WRITE (nulprt,*) 'start_grids_writing: err= ', mpi_err 00335 WRITE (nulprt,*) 'start_grids_writing: STOP' 00336 STOP 00337 ENDIF 00338 #ifdef __VERBOSE 00339 WRITE (nulprt,*) ' ' 00340 WRITE (nulprt,*) ' grids file name: ', cgrdnam 00341 WRITE (nulprt,*) ' masks file name: ', cmsknam 00342 WRITE (nulprt,*) ' areas file name: ', csurnam 00343 WRITE (nulprt,*) ' suffix for longitudes: ', cglonsuf 00344 WRITE (nulprt,*) ' suffix for latitudes: ', cglatsuf 00345 WRITE (nulprt,*) ' suffix for corner longitudes: ', crnlonsuf 00346 WRITE (nulprt,*) ' suffix for corner latitudes: ', crnlatsuf 00347 WRITE (nulprt,*) ' suffix for masks: ', cmsksuf 00348 WRITE (nulprt,*) ' suffix for areas: ', csursuf 00349 WRITE (nulprt,*) ' suffix for angles: ', cangsuf 00350 call flush(nulprt) 00351 #endif 00352 #endif 00353 00354 ELSE IF (grids_start == 0) THEN 00355 ! 00356 !-- grids file already exists, no writing needed 00357 ! 00358 #ifdef __VERBOSE 00359 WRITE (nulprt,*) ' grids file exists, no writing needed' 00360 call flush(nulprt) 00361 #endif 00362 gridswrite = .false. 00363 ELSE 00364 WRITE (nulprt,*) ' ' 00365 WRITE (nulprt,*) 'start_grids_writing: no valid flag received' 00366 WRITE (nulprt,*) 'start_grids_writing: grids_start= ', grids_start 00367 WRITE (nulprt,*) 'start_grids_writing: STOP' 00368 STOP 00369 ENDIF 00370 00371 IF (gridswrite) THEN 00372 iwrite = 1 00373 ENDIF 00374 00375 #ifdef __VERBOSE 00376 write(nulprt,*) '| | | Leaving - - prism_start_grids_writing' 00377 write(nulprt,*) '' 00378 CALL FLUSH(nulprt) 00379 #endif 00380 RETURN 00381 00382 END SUBROUTINE prism_start_grids_writing 00383 00384 !-------------------------------------------------------------------------- 00385 ! 00386 SUBROUTINE prism_write_grid(cgrid, nx, ny, lon, lat) 00387 !-------------------------------------------------------------------------- 00388 ! Routine to create a new grids file or to add a grid description to an 00389 ! existing grids file. 00390 !-------------------------------------------------------------------------- 00391 #if defined use_comm_GSIP 00392 USE mod_gsip_model 00393 #endif 00394 IMPLICIT NONE 00395 #ifndef use_comm_GSIP 00396 #ifdef use_netCDF 00397 #include <netcdf.inc> 00398 #endif 00399 #else 00400 INTEGER :: mgi_write, il_errgsip 00401 #endif 00402 CHARACTER*4, INTENT (IN) :: cgrid ! grid acronym 00403 INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx ! number of longitudes 00404 INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny ! number of latitudes 00405 REAL(kind=ip_realwp_p), INTENT (IN) :: lon(nx,ny) ! longitudes 00406 REAL(kind=ip_realwp_p), INTENT (IN) :: lat(nx,ny) ! latitudes 00407 00408 INTEGER(kind=ip_intwp_p) :: iost ! i/o status 00409 INTEGER(kind=ip_intwp_p) :: nulgrd ! logical unit of grids file 00410 INTEGER(kind=ip_intwp_p) :: stat ! netcdf status 00411 INTEGER(kind=ip_intwp_p) :: ncid ! netcdf file id 00412 INTEGER(kind=ip_intwp_p) :: idx, idy ! netcdf dimension ids 00413 INTEGER(kind=ip_intwp_p) :: idlon, idlat ! netcdf variable ids 00414 INTEGER(kind=ip_intwp_p) :: dims(2) ! netcdf variable dimensions 00415 INTEGER(kind=ip_intwp_p) :: il_nftype ! netcdf type 00416 00417 LOGICAL :: existent !true if grids file is already existing 00418 LOGICAL :: grdopen !true if grids file is opened 00419 00420 CHARACTER*8 :: clon !locator sring (binary) / variable name (netcdf) 00421 CHARACTER*8 :: clat !locator sring (binary) / variable name (netcdf) 00422 00423 !-------------------------------------------------------------------------- 00424 00425 #ifdef __VERBOSE 00426 write(nulprt,*) ' ' 00427 write(nulprt,*) '| | | Entering - - prism_write_grid' 00428 write(nulprt,*) ' grid acronym: ', cgrid 00429 call flush(nulprt) 00430 #endif 00431 ! 00432 !-- Return, if grids files already exists 00433 ! 00434 IF (.NOT. gridswrite) THEN 00435 write(nulprt,*) ' ' 00436 write(nulprt,*) 'No grid writing needed' 00437 RETURN 00438 ENDIF 00439 ! 00440 #if defined use_comm_GSIP 00441 ! 00442 !-- Send flag to coupler to tell it that grids will be send 00443 il_errgsip = mgi_write (ig_gsipw, 100, 1, 'I') 00444 il_errgsip = mgi_write (ig_gsipw, cgrid, 4, 'C') 00445 il_errgsip = mgi_write (ig_gsipw, nx, 1, 'I') 00446 il_errgsip = mgi_write (ig_gsipw, ny, 1, 'I') 00447 il_errgsip = mgi_write (ig_gsipw, lon, nx*ny, 'R') 00448 il_errgsip = mgi_write (ig_gsipw, lat, nx*ny, 'R') 00449 ! 00450 #else 00451 #ifdef use_netCDF 00452 IF (l_netcdf) THEN 00453 ! ------------- 00454 !-- netCDF format 00455 ! ------------- 00456 ! 00457 il_nftype = NF_DOUBLE 00458 IF (ll_single) il_nftype = NF_REAL 00459 ! 00460 ! open grids file 00461 ! --------------- 00462 stat = NF_OPEN(cgrdnam//'.nc', NF_WRITE, ncid) 00463 IF (stat /= NF_NOERR) THEN 00464 stat = NF_CREATE(cgrdnam//'.nc', NF_CLOBBER, ncid) 00465 IF (stat /= NF_NOERR) THEN 00466 WRITE (nulprt,*) 'prism_write_grid: error opening grids file.' 00467 WRITE (nulprt,*) 'prism_write_grid: STOP' 00468 STOP 00469 ENDIF 00470 ENDIF 00471 ! 00472 !-- define dimensions 00473 ! ----------------- 00474 stat = NF_REDEF(ncid) 00475 stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx) 00476 IF (stat .NE. NF_NOERR) THEN 00477 stat = NF_DEF_DIM(ncid, 'x_'//cgrid, nx, idx) 00478 IF (stat /= NF_NOERR) THEN 00479 WRITE (nulprt,*) 'ERROR defining dimension x_',cgrid 00480 ENDIF 00481 ELSE 00482 WRITE(nulprt,*)'Grid already defined: ', cgrid 00483 RETURN 00484 ENDIF 00485 stat = NF_DEF_DIM(ncid, 'y_'//cgrid, ny, idy) 00486 IF (stat /= NF_NOERR) THEN 00487 WRITE (nulprt,*) 'ERROR defining dimension y_',cgrid 00488 ENDIF 00489 00490 dims(1) = idx 00491 dims(2) = idy 00492 ! 00493 !-- define longitudes 00494 ! ----------------- 00495 clon=cgrid//cglonsuf 00496 stat = NF_DEF_VAR (ncid, clon , il_nftype, 2, dims, idlon) 00497 IF (stat /= NF_NOERR) THEN 00498 WRITE (nulprt,*) 'ERROR defining variable ', clon 00499 ENDIF 00500 stat = NF_PUT_ATT_TEXT(ncid,idlon,'long_name',18,'Longitudes of '//cgrid) 00501 IF (stat /= NF_NOERR) THEN 00502 WRITE (nulprt,*) 'ERROR creating att. for longitudes of ', cgrid 00503 ENDIF 00504 stat = NF_PUT_ATT_TEXT(ncid, idlon, 'units', 8, 'degree_E') 00505 IF (stat /= NF_NOERR) THEN 00506 WRITE (nulprt,*) 'ERROR creating att. for longitudes of ', cgrid 00507 ENDIF 00508 ! 00509 !-- define latitudes 00510 ! ---------------- 00511 clat=cgrid//cglatsuf 00512 stat = NF_DEF_VAR (ncid, clat , il_nftype, 2, dims, idlat) 00513 IF (stat /= NF_NOERR) THEN 00514 WRITE (nulprt,*) 'ERROR defining variable ', clat 00515 ENDIF 00516 stat = NF_PUT_ATT_TEXT(ncid, idlat,'long_name',17,'Latitudes of '//cgrid) 00517 IF (stat /= NF_NOERR) THEN 00518 WRITE (nulprt,*) 'ERROR creating att. for latitudes of ', cgrid 00519 ENDIF 00520 stat = NF_PUT_ATT_TEXT(ncid, idlat, 'units', 8, 'degree_N') 00521 IF (stat /= NF_NOERR) THEN 00522 WRITE (nulprt,*) 'ERROR creating att. for latitudes of ', cgrid 00523 ENDIF 00524 ! 00525 !-- switch to data mode 00526 ! ------------------- 00527 stat = NF_ENDDEF(ncid) 00528 IF (stat /= NF_NOERR) THEN 00529 WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode' 00530 ENDIF 00531 ! 00532 !-- write longitudes 00533 ! ---------------- 00534 IF (ll_single) THEN 00535 stat = NF_PUT_VAR_REAL (ncid, idlon, lon(:,:)) 00536 ELSE 00537 stat = NF_PUT_VAR_DOUBLE (ncid, idlon, lon(:,:)) 00538 ENDIF 00539 IF (stat /= NF_NOERR) THEN 00540 WRITE (nulprt,*) 'ERROR writing lonitudes of ', cgrid 00541 ENDIF 00542 ! 00543 !-- write latitudes 00544 ! --------------- 00545 IF (ll_single) THEN 00546 stat = NF_PUT_VAR_REAL (ncid, idlat, lat(:,:)) 00547 ELSE 00548 stat = NF_PUT_VAR_DOUBLE (ncid, idlat, lat(:,:)) 00549 ENDIF 00550 IF (stat /= NF_NOERR) THEN 00551 WRITE (nulprt,*) 'ERROR writing latitudes of ', cgrid 00552 ENDIF 00553 ! 00554 !-- close grids file 00555 ! ---------------- 00556 stat = NF_CLOSE(ncid) 00557 IF (stat /= NF_NOERR) THEN 00558 WRITE (nulprt,*) 'ERROR closing file', cgrdnam 00559 ENDIF 00560 00561 ELSE 00562 #endif 00563 ! ------------- 00564 !-- binary format 00565 ! ------------- 00566 ! 00567 ! open grids file 00568 ! --------------- 00569 INQUIRE (FILE = cgrdnam, EXIST = existent, OPENED = grdopen) 00570 IF (existent .AND. grdopen) THEN 00571 WRITE (nulprt,*) ' ' 00572 WRITE (nulprt,*) 'prism_write_grid: grids file already opened' 00573 WRITE (nulprt,*) 'prism_write_grid: STOP' 00574 STOP 00575 ENDIF 00576 iost = 0 00577 nulgrd = 7 00578 INQUIRE (nulgrd,OPENED = grdopen) 00579 DO WHILE (grdopen) 00580 nulgrd = nulgrd + 1 00581 INQUIRE (nulgrd,OPENED = grdopen) 00582 END DO 00583 00584 OPEN (UNIT=nulgrd, FILE=cgrdnam, STATUS='UNKNOWN', & 00585 ACCESS='SEQUENTIAL', FORM='UNFORMATTED', POSITION='APPEND', & 00586 ACTION='WRITE', IOSTAT=iost, ERR=110) 00587 00588 110 CONTINUE 00589 IF (iost /= 0) THEN 00590 WRITE (nulprt,*) ' ' 00591 WRITE (nulprt,*) 'prism_write_grid: Error opening grids file' 00592 WRITE (nulprt,*) 'prism_write_grid: STOP' 00593 STOP 00594 ENDIF 00595 00596 ! write longitudes 00597 ! ---------------- 00598 clon=cgrid//cglonsuf 00599 WRITE (UNIT = nulgrd) clon 00600 WRITE (UNIT = nulgrd) lon(:,:) 00601 00602 ! write latitudes 00603 ! ---------------- 00604 clat=cgrid//cglatsuf 00605 WRITE (UNIT = nulgrd) clat 00606 WRITE (UNIT = nulgrd) lat(:,:) 00607 00608 ! close grids file 00609 ! ---------------- 00610 CLOSE (nulgrd) 00611 #ifdef use_netCDF 00612 ENDIF 00613 #endif 00614 #endif 00615 #ifdef __VERBOSE 00616 write(nulprt,*) '| | | Leaving - - prism_write_grid' 00617 write(nulprt,*) ' ' 00618 CALL FLUSH(nulprt) 00619 #endif 00620 00621 RETURN 00622 00623 END SUBROUTINE prism_write_grid 00624 !-------------------------------------------------------------------------- 00625 ! 00626 !-------------------------------------------------------------------------- 00627 ! 00628 SUBROUTINE prism_write_angle(cgrid, nx, ny, angle) 00629 !-------------------------------------------------------------------------- 00630 ! Routine to add angles to an existing grid file. 00631 !-------------------------------------------------------------------------- 00632 #if defined use_comm_GSIP 00633 USE mod_gsip_model 00634 #endif 00635 IMPLICIT NONE 00636 #ifndef use_comm_GSIP 00637 #ifdef use_netCDF 00638 #include <netcdf.inc> 00639 #endif 00640 #else 00641 INTEGER :: mgi_write, il_errgsip 00642 #endif 00643 CHARACTER*4, INTENT (IN) :: cgrid ! grid acronym 00644 INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx ! number of longitudes 00645 INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny ! number of latitudes 00646 REAL(kind=ip_realwp_p), INTENT (IN) :: angle(nx,ny) ! angles 00647 00648 INTEGER(kind=ip_intwp_p) :: iost ! i/o status 00649 INTEGER(kind=ip_intwp_p) :: nulsrf ! logical unit of grid file 00650 INTEGER(kind=ip_intwp_p) :: stat ! netcdf status 00651 INTEGER(kind=ip_intwp_p) :: ncid ! netcdf file id 00652 INTEGER(kind=ip_intwp_p) :: idx, idy ! netcdf dimension ids 00653 INTEGER(kind=ip_intwp_p) :: idsrf ! netcdf variable id 00654 INTEGER(kind=ip_intwp_p) :: dims(2) ! netcdf variable dimensions 00655 INTEGER(kind=ip_intwp_p) :: il_nftype ! netcdf type 00656 00657 LOGICAL :: existent !true if grid file is already existing 00658 LOGICAL :: srfopen !true if grid file is opened 00659 00660 CHARACTER*8 :: csrf !locator sring (binary) / variable name (netcdf) 00661 00662 !-------------------------------------------------------------------------- 00663 00664 #ifdef __VERBOSE 00665 write(nulprt,*) ' ' 00666 write(nulprt,*) '| | | Entering - - prism_write_angle' 00667 write(nulprt,*) ' grid acronym: ', cgrid 00668 CALL FLUSH(nulprt) 00669 #endif 00670 00671 ! 00672 !-- Return, if areas files already exists 00673 ! 00674 IF (.NOT. gridswrite) THEN 00675 write(nulprt,*) ' ' 00676 write(nulprt,*) 'No angles writing needed' 00677 RETURN 00678 ENDIF 00679 ! 00680 #if defined use_comm_GSIP 00681 ! 00682 WRITE(nulprt,*) ' ' 00683 WRITE(nulprt,*) 'Error: prism_write_angle not adapted for GSIP.' 00684 WRITE(nulprt,*) 'prism_write_angle: STOP' 00685 STOP 00686 ! 00687 #else 00688 #ifdef use_netCDF 00689 IF (l_netcdf) THEN 00690 ! ------------- 00691 !-- netCDF format 00692 ! ------------- 00693 ! 00694 il_nftype = NF_DOUBLE 00695 IF (ll_single) il_nftype = NF_REAL 00696 ! 00697 ! open areas file 00698 ! --------------- 00699 stat = NF_OPEN(cgrdnam//'.nc', NF_WRITE, ncid) 00700 IF (stat /= NF_NOERR) THEN 00701 stat = NF_CREATE(cgrdnam//'.nc', NF_CLOBBER, ncid) 00702 IF (stat /= NF_NOERR) THEN 00703 WRITE (nulprt,*) 'prism_write_angle: error opening grid file.' 00704 WRITE (nulprt,*) 'prism_write_angle: STOP' 00705 STOP 00706 ENDIF 00707 ENDIF 00708 ! 00709 !-- define dimensions 00710 ! ----------------- 00711 stat = NF_REDEF(ncid) 00712 stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx) 00713 IF (stat .NE. NF_NOERR) THEN 00714 stat = NF_DEF_DIM(ncid, 'x_'//cgrid, nx, idx) 00715 IF (stat /= NF_NOERR) THEN 00716 WRITE (nulprt,*) 'ERROR defining dimension x_',cgrid 00717 ENDIF 00718 ELSE 00719 WRITE(nulprt,*)'Angles already defined: ', cgrid 00720 RETURN 00721 ENDIF 00722 stat = NF_DEF_DIM(ncid, 'y_'//cgrid, ny, idy) 00723 IF (stat /= NF_NOERR) THEN 00724 WRITE (nulprt,*) 'ERROR defining dimension y_',cgrid 00725 ENDIF 00726 00727 dims(1) = idx 00728 dims(2) = idy 00729 ! 00730 !-- define angles 00731 ! ------------ 00732 csrf=cgrid//csursuf 00733 stat = NF_DEF_VAR (ncid, csrf , il_nftype, 2, dims, idsrf) 00734 IF (stat /= NF_NOERR) THEN 00735 WRITE (nulprt,*) 'ERROR defining variable ', csrf 00736 ENDIF 00737 stat = NF_PUT_ATT_TEXT(ncid,idsrf,'long_name',13,'Angles of '//cgrid) 00738 IF (stat /= NF_NOERR) THEN 00739 WRITE (nulprt,*) 'ERROR creating att. for angles of ', cgrid 00740 ENDIF 00741 stat = NF_PUT_ATT_TEXT(ncid, idsrf, 'units', 2, 'm2') 00742 IF (stat /= NF_NOERR) THEN 00743 WRITE (nulprt,*) 'ERROR creating att. for angles of ', cgrid 00744 ENDIF 00745 ! 00746 !-- switch to data mode 00747 ! ------------------- 00748 stat = NF_ENDDEF(ncid) 00749 IF (stat /= NF_NOERR) THEN 00750 WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode' 00751 ENDIF 00752 ! 00753 !-- write angles 00754 ! ----------- 00755 IF (ll_single) THEN 00756 stat = NF_PUT_VAR_REAL (ncid, idsrf, angle(:,:)) 00757 ELSE 00758 stat = NF_PUT_VAR_DOUBLE (ncid, idsrf, angle(:,:)) 00759 ENDIF 00760 IF (stat /= NF_NOERR) THEN 00761 WRITE (nulprt,*) 'ERROR writing angle of ', cgrid 00762 ENDIF 00763 ! 00764 !-- close angles file 00765 ! ---------------- 00766 stat = NF_CLOSE(ncid) 00767 IF (stat /= NF_NOERR) THEN 00768 WRITE (nulprt,*) 'ERROR closing file', cgrdnam 00769 ENDIF 00770 00771 ELSE 00772 #endif 00773 ! ------------- 00774 !-- binary format 00775 ! ------------- 00776 ! 00777 ! open grid file 00778 ! --------------- 00779 INQUIRE (FILE = cgrdnam, EXIST = existent, OPENED = srfopen) 00780 IF (existent .AND. srfopen) THEN 00781 WRITE (nulprt,*) ' ' 00782 WRITE (nulprt,*) 'prism_write_angle: grid file already opened' 00783 WRITE (nulprt,*) 'prism_write_angle: STOP' 00784 STOP 00785 ENDIF 00786 iost = 0 00787 nulsrf = 7 00788 INQUIRE (nulsrf,OPENED = srfopen) 00789 DO WHILE (srfopen) 00790 nulsrf = nulsrf + 1 00791 INQUIRE (nulsrf,OPENED = srfopen) 00792 END DO 00793 00794 OPEN (UNIT=nulsrf, FILE=cgrdnam, STATUS='UNKNOWN', & 00795 ACCESS='SEQUENTIAL', FORM='UNFORMATTED', POSITION='APPEND', & 00796 ACTION='WRITE', IOSTAT=iost, ERR=110) 00797 00798 110 CONTINUE 00799 IF (iost /= 0) THEN 00800 WRITE (nulprt,*) ' ' 00801 WRITE (nulprt,*) 'prism_write_angle: Error opening grid file' 00802 WRITE (nulprt,*) 'prism_write_angle: STOP' 00803 STOP 00804 ENDIF 00805 00806 ! write angles 00807 ! ----------- 00808 csrf=cgrid//cangsuf 00809 WRITE (UNIT = nulsrf) csrf 00810 WRITE (UNIT = nulsrf) angle(:,:) 00811 00812 ! close areas file 00813 ! ---------------- 00814 CLOSE (nulsrf) 00815 #ifdef use_netCDF 00816 ENDIF 00817 #endif 00818 #endif 00819 #ifdef __VERBOSE 00820 write(nulprt,*) '| | | Leaving - - prism_write_angle' 00821 write(nulprt,*) ' ' 00822 CALL FLUSH(nulprt) 00823 #endif 00824 00825 RETURN 00826 00827 END SUBROUTINE prism_write_angle 00828 00829 !-------------------------------------------------------------------------- 00830 ! 00831 SUBROUTINE prism_write_corner(cgrid, nx, ny, nc, clon, clat) 00832 !-------------------------------------------------------------------------- 00833 ! Routine to add longitudes and latitudes of grid cell corners to an 00834 ! existing grids file. 00835 !-------------------------------------------------------------------------- 00836 #if defined use_comm_GSIP 00837 USE mod_gsip_model 00838 #endif 00839 IMPLICIT NONE 00840 #ifndef use_comm_GSIP 00841 #ifdef use_netCDF 00842 #include <netcdf.inc> 00843 #endif 00844 #else 00845 INTEGER :: mgi_write, il_errgsip 00846 #endif 00847 CHARACTER*4, INTENT (IN) :: cgrid ! grid acronym 00848 INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx ! number of longitudes 00849 INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny ! number of latitudes 00850 INTEGER(kind=ip_intwp_p), INTENT (IN) :: nc ! number of corners per cell 00851 REAL(kind=ip_realwp_p), INTENT (IN) :: clon(nx,ny,nc) ! longitudes 00852 REAL(kind=ip_realwp_p), INTENT (IN) :: clat(nx,ny,nc) ! latitudes 00853 00854 INTEGER(kind=ip_intwp_p) :: stat ! netcdf status 00855 INTEGER(kind=ip_intwp_p) :: ncid ! netcdf file id 00856 INTEGER(kind=ip_intwp_p) :: idx, idy, idc ! netcdf dimension ids 00857 INTEGER(kind=ip_intwp_p) :: idclon, idclat ! netcdf variable ids 00858 INTEGER(kind=ip_intwp_p) :: dims(3) ! netcdf variable dimensions 00859 00860 INTEGER(kind=ip_intwp_p) :: il_nftype ! netcdf type 00861 00862 CHARACTER*8 :: crnlon !locator sring (binary) / variable name (netcdf) 00863 CHARACTER*8 :: crnlat !locator sring (binary) / variable name (netcdf) 00864 00865 !-------------------------------------------------------------------------- 00866 00867 #ifdef __VERBOSE 00868 write(nulprt,*) ' ' 00869 write(nulprt,*) '| | | Entering - - prism_write_corner' 00870 write(nulprt,*) ' grid acronym: ', cgrid 00871 CALL FLUSH(nulprt) 00872 #endif 00873 00874 ! 00875 !-- Return, if grids files was written in a former run 00876 ! 00877 IF (.NOT. gridswrite) THEN 00878 write(nulprt,*) ' ' 00879 write(nulprt,*) 'No grid writing needed' 00880 RETURN 00881 ENDIF 00882 ! 00883 #if defined use_comm_GSIP 00884 ! 00885 !-- Send flag to coupler to tell it that grids will be send 00886 il_errgsip = mgi_write (ig_gsipw, 200, 1, 'I') 00887 il_errgsip = mgi_write (ig_gsipw, cgrid, 4, 'C') 00888 il_errgsip = mgi_write (ig_gsipw, nx, 1, 'I') 00889 il_errgsip = mgi_write (ig_gsipw, ny, 1, 'I') 00890 il_errgsip = mgi_write (ig_gsipw, nc, 1, 'I') 00891 il_errgsip = mgi_write (ig_gsipw, clon, nx*ny*nc, 'R') 00892 il_errgsip = mgi_write (ig_gsipw, clat, nx*ny*nc, 'R') 00893 ig_noc = nc 00894 ! 00895 #else 00896 #ifdef use_netCDF 00897 IF (l_netcdf) THEN 00898 ! ------------- 00899 !-- netCDF format 00900 ! ------------- 00901 ! 00902 il_nftype = NF_DOUBLE 00903 IF (ll_single) il_nftype = NF_REAL 00904 ! 00905 ! open grids file 00906 ! --------------- 00907 stat = NF_OPEN(cgrdnam//'.nc', NF_WRITE, ncid) 00908 IF (stat /= NF_NOERR) THEN 00909 WRITE (nulprt,*) ' ' 00910 WRITE (nulprt,*) 'prism_write_corner: ERROR' 00911 WRITE (nulprt,*) 'prism_write_corner: grids.nc file does not exist!' 00912 WRITE (nulprt,*) 'prism_write_corner: call prism_write_grid first!' 00913 WRITE (nulprt,*) 'prism_write_corner: STOP' 00914 STOP 00915 ENDIF 00916 ! 00917 !-- define corner dimensions 00918 ! ------------------------ 00919 stat = NF_REDEF(ncid) 00920 stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx) 00921 IF (stat /= NF_NOERR) THEN 00922 WRITE (nulprt,*) 'ERROR finding out dimension id of x_',cgrid 00923 ENDIF 00924 stat = NF_INQ_DIMID(ncid, 'y_'//cgrid, idy) 00925 IF (stat /= NF_NOERR) THEN 00926 WRITE (nulprt,*) 'ERROR finding out dimension id of y_',cgrid 00927 ENDIF 00928 stat = NF_DEF_DIM(ncid, 'crn_'//cgrid, nc, idc) 00929 IF (stat /= NF_NOERR) THEN 00930 WRITE (nulprt,*) 'ERROR defining dimension crn_',cgrid 00931 ENDIF 00932 00933 dims(1) = idx 00934 dims(2) = idy 00935 dims(3) = idc 00936 ig_noc = nc 00937 ! 00938 !-- define corner longitudes 00939 ! ------------------------ 00940 crnlon=cgrid//crnlonsuf 00941 stat = NF_INQ_VARID (ncid, crnlon, idclon) 00942 IF (stat .NE. NF_NOERR) THEN 00943 stat = NF_DEF_VAR (ncid, crnlon , il_nftype, 3, dims, idclon) 00944 IF (stat /= NF_NOERR) THEN 00945 WRITE (nulprt,*) 'ERROR defining variable ', crnlon 00946 ENDIF 00947 stat = NF_PUT_ATT_TEXT & 00948 (ncid,idclon,'long_name',39,'Longitudes of grid cell corners of '//cgrid) 00949 IF (stat /= NF_NOERR) THEN 00950 WRITE (nulprt,*) 'ERROR creating att. for corner longitudes of ', cgrid 00951 ENDIF 00952 stat = NF_PUT_ATT_TEXT(ncid, idclon, 'units', 8, 'degree_E') 00953 IF (stat /= NF_NOERR) THEN 00954 WRITE (nulprt,*) 'ERROR creating att. for corner longitudes of ', cgrid 00955 ENDIF 00956 ELSE 00957 WRITE(nulprt,*)'Corners already defined: ', cgrid 00958 RETURN 00959 ENDIF 00960 ! 00961 !-- define corner latitudes 00962 ! ----------------------- 00963 crnlat=cgrid//crnlatsuf 00964 stat = NF_DEF_VAR (ncid, crnlat , il_nftype, 3, dims, idclat) 00965 IF (stat /= NF_NOERR) THEN 00966 WRITE (nulprt,*) 'ERROR defining variable ', crnlat 00967 ENDIF 00968 stat = NF_PUT_ATT_TEXT & 00969 (ncid, idclat,'long_name',38,'Latitudes of grid cell corners of '//cgrid) 00970 IF (stat /= NF_NOERR) THEN 00971 WRITE (nulprt,*) 'ERROR creating att. for corner latitudes of ', cgrid 00972 ENDIF 00973 stat = NF_PUT_ATT_TEXT(ncid, idclat, 'units', 8, 'degree_N') 00974 IF (stat /= NF_NOERR) THEN 00975 WRITE (nulprt,*) 'ERROR creating att. for corner latitudes of ', cgrid 00976 ENDIF 00977 ! 00978 !-- switch to data mode 00979 ! ------------------- 00980 stat = NF_ENDDEF(ncid) 00981 IF (stat /= NF_NOERR) THEN 00982 WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode' 00983 ENDIF 00984 ! 00985 !-- write longitudes 00986 ! ---------------- 00987 IF (ll_single) THEN 00988 stat = NF_PUT_VAR_REAL (ncid, idclon, clon(:,:,:)) 00989 ELSE 00990 stat = NF_PUT_VAR_DOUBLE (ncid, idclon, clon(:,:,:)) 00991 ENDIF 00992 IF (stat /= NF_NOERR) THEN 00993 WRITE (nulprt,*) 'ERROR writing corner lonitudes of ', cgrid 00994 ENDIF 00995 ! 00996 !-- write latitudes 00997 ! --------------- 00998 IF (ll_single) THEN 00999 stat = NF_PUT_VAR_REAL (ncid, idclat, clat(:,:,:)) 01000 ELSE 01001 stat = NF_PUT_VAR_DOUBLE (ncid, idclat, clat(:,:,:)) 01002 ENDIF 01003 IF (stat /= NF_NOERR) THEN 01004 WRITE (nulprt,*) 'ERROR writing corner latitudes of ', cgrid 01005 ENDIF 01006 ! 01007 !-- close grids file 01008 ! ---------------- 01009 stat = NF_CLOSE(ncid) 01010 IF (stat /= NF_NOERR) THEN 01011 WRITE (nulprt,*) 'ERROR closing file', cgrdnam 01012 ENDIF 01013 01014 ELSE 01015 #endif 01016 ! ------------- 01017 !-- binary format 01018 ! ------------- 01019 WRITE (nulprt,*) ' ' 01020 WRITE (nulprt,*) 'prisn_write_corner: WARNING: ' 01021 WRITE (nulprt,*) 'prism_write_corner: Binary format not supported' 01022 WRITE (nulprt,*) 'prism_write_corner: No corners added' 01023 #ifdef use_netCDF 01024 ENDIF 01025 #endif 01026 #endif 01027 #ifdef __VERBOSE 01028 write(nulprt,*) '| | | Leaving - - prism_write_corner' 01029 write(nulprt,*) ' ' 01030 CALL FLUSH(nulprt) 01031 #endif 01032 01033 RETURN 01034 01035 END SUBROUTINE prism_write_corner 01036 !-------------------------------------------------------------------------- 01037 ! 01038 SUBROUTINE prism_write_mask(cgrid, nx, ny, mask) 01039 !-------------------------------------------------------------------------- 01040 ! Routine to create a new masks file or to add a land see mask to an 01041 ! existing masks file. 01042 !-------------------------------------------------------------------------- 01043 #if defined use_comm_GSIP 01044 USE mod_gsip_model 01045 #endif 01046 IMPLICIT NONE 01047 #ifndef use_comm_GSIP 01048 #ifdef use_netCDF 01049 #include <netcdf.inc> 01050 #endif 01051 #else 01052 INTEGER :: mgi_write, il_errgsip 01053 #endif 01054 CHARACTER*4, INTENT (IN) :: cgrid ! grid acronym 01055 INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx ! number of longitudes 01056 INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny ! number of latitudes 01057 INTEGER(kind=ip_intwp_p), INTENT (IN) :: mask(nx,ny) ! mask 01058 01059 INTEGER(kind=ip_intwp_p) :: iost ! i/o status 01060 INTEGER(kind=ip_intwp_p) :: nulmsk ! logical unit of masks file 01061 INTEGER(kind=ip_intwp_p) :: stat ! netcdf status 01062 INTEGER(kind=ip_intwp_p) :: ncid ! netcdf file id 01063 INTEGER(kind=ip_intwp_p) :: idx, idy ! netcdf dimension ids 01064 INTEGER(kind=ip_intwp_p) :: idmsk ! netcdf variable id 01065 INTEGER(kind=ip_intwp_p) :: dims(2) ! netcdf variable dimensions 01066 01067 LOGICAL :: existent !true if masks file is already existing 01068 LOGICAL :: mskopen !true if masks file is opened 01069 01070 CHARACTER*8 :: cmsk !locator sring (binary) / variable name (netcdf) 01071 01072 !-------------------------------------------------------------------------- 01073 01074 #ifdef __VERBOSE 01075 write(nulprt,*) ' ' 01076 write(nulprt,*) '| | | Entering - - prism_write_mask' 01077 write(nulprt,*) ' grid acronym: ', cgrid 01078 CALL FLUSH(nulprt) 01079 #endif 01080 01081 ! 01082 !-- Return, if masks files already exists 01083 ! 01084 IF (.NOT. gridswrite) THEN 01085 write(nulprt,*) ' ' 01086 write(nulprt,*) 'No mask writing needed' 01087 RETURN 01088 ENDIF 01089 #if defined use_comm_GSIP 01090 ! 01091 !-- Send flag to coupler to tell it that grids will be send 01092 il_errgsip = mgi_write (ig_gsipw, 300, 1, 'I') 01093 il_errgsip = mgi_write (ig_gsipw, cgrid, 4, 'C') 01094 il_errgsip = mgi_write (ig_gsipw, nx, 1, 'I') 01095 il_errgsip = mgi_write (ig_gsipw, ny, 1, 'I') 01096 il_errgsip = mgi_write (ig_gsipw, mask, nx*ny, 'I') 01097 ! 01098 #else 01099 #ifdef use_netCDF 01100 IF (l_netcdf) THEN 01101 ! ------------- 01102 !-- netCDF format 01103 ! ------------- 01104 ! 01105 ! open masks file 01106 ! --------------- 01107 stat = NF_OPEN(cmsknam//'.nc', NF_WRITE, ncid) 01108 IF (stat /= NF_NOERR) THEN 01109 stat = NF_CREATE(cmsknam//'.nc', NF_CLOBBER, ncid) 01110 IF (stat /= NF_NOERR) THEN 01111 WRITE (nulprt,*) 'prism_write_mask: error opening masks file.' 01112 WRITE (nulprt,*) 'prism_write_mask: STOP' 01113 STOP 01114 ENDIF 01115 ENDIF 01116 ! 01117 !-- define dimensions 01118 ! ----------------- 01119 stat = NF_REDEF(ncid) 01120 stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx) 01121 IF (stat .NE. NF_NOERR) THEN 01122 stat = NF_DEF_DIM(ncid, 'x_'//cgrid, nx, idx) 01123 IF (stat /= NF_NOERR) THEN 01124 WRITE (nulprt,*) 'ERROR defining dimension x_',cgrid 01125 ENDIF 01126 ELSE 01127 WRITE(nulprt,*)'Mask already defined: ', cgrid 01128 RETURN 01129 ENDIF 01130 stat = NF_DEF_DIM(ncid, 'y_'//cgrid, ny, idy) 01131 IF (stat /= NF_NOERR) THEN 01132 WRITE (nulprt,*) 'ERROR defining dimension y_',cgrid 01133 ENDIF 01134 01135 dims(1) = idx 01136 dims(2) = idy 01137 ! 01138 !-- define mask 01139 ! ----------- 01140 cmsk=cgrid//cmsksuf 01141 stat = NF_DEF_VAR (ncid, cmsk , NF_INT, 2, dims, idmsk) 01142 IF (stat /= NF_NOERR) THEN 01143 WRITE (nulprt,*) 'ERROR defining variable ', cmsk 01144 ENDIF 01145 stat = NF_PUT_ATT_TEXT(ncid,idmsk,'long_name',12,'Mask of '//cgrid) 01146 IF (stat /= NF_NOERR) THEN 01147 WRITE (nulprt,*) 'ERROR creating att. for mask of ', cgrid 01148 ENDIF 01149 stat = NF_PUT_ATT_TEXT(ncid, idmsk, 'units', 1, '1') 01150 IF (stat /= NF_NOERR) THEN 01151 WRITE (nulprt,*) 'ERROR creating att. for mask of ', cgrid 01152 ENDIF 01153 ! 01154 !-- switch to data mode 01155 ! ------------------- 01156 stat = NF_ENDDEF(ncid) 01157 IF (stat /= NF_NOERR) THEN 01158 WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode' 01159 ENDIF 01160 ! 01161 !-- write mask 01162 ! ---------- 01163 stat = NF_PUT_VAR_INT (ncid, idmsk, mask(:,:)) 01164 IF (stat /= NF_NOERR) THEN 01165 WRITE (nulprt,*) 'ERROR writing mask of ', cgrid 01166 ENDIF 01167 ! 01168 !-- close masks file 01169 ! ---------------- 01170 stat = NF_CLOSE(ncid) 01171 IF (stat /= NF_NOERR) THEN 01172 WRITE (nulprt,*) 'ERROR closing file', cmsknam 01173 ENDIF 01174 01175 ELSE 01176 #endif 01177 ! ------------- 01178 !-- binary format 01179 ! ------------- 01180 ! 01181 ! open masks file 01182 ! --------------- 01183 INQUIRE (FILE = cmsknam, EXIST = existent, OPENED = mskopen) 01184 IF (existent .AND. mskopen) THEN 01185 WRITE (nulprt,*) ' ' 01186 WRITE (nulprt,*) 'prism_write_mask: masks file already opened' 01187 WRITE (nulprt,*) 'prism_write_mask: STOP' 01188 STOP 01189 ENDIF 01190 iost = 0 01191 nulmsk = 7 01192 INQUIRE (nulmsk,OPENED = mskopen) 01193 DO WHILE (mskopen) 01194 nulmsk = nulmsk + 1 01195 INQUIRE (nulmsk,OPENED = mskopen) 01196 END DO 01197 01198 OPEN (UNIT=nulmsk, FILE=cmsknam, STATUS='UNKNOWN', & 01199 ACCESS='SEQUENTIAL', FORM='UNFORMATTED', POSITION='APPEND', & 01200 ACTION='WRITE', IOSTAT=iost, ERR=110) 01201 01202 110 CONTINUE 01203 IF (iost /= 0) THEN 01204 WRITE (nulprt,*) ' ' 01205 WRITE (nulprt,*) 'prism_write_mask: Error opening masks file' 01206 WRITE (nulprt,*) 'prism_write_mask: STOP' 01207 STOP 01208 ENDIF 01209 01210 ! write maks 01211 ! ---------- 01212 cmsk=cgrid//cmsksuf 01213 WRITE (UNIT = nulmsk) cmsk 01214 WRITE (UNIT = nulmsk) mask(:,:) 01215 01216 ! close grids file 01217 ! ---------------- 01218 CLOSE (nulmsk) 01219 #ifdef use_netCDF 01220 ENDIF 01221 #endif 01222 #endif 01223 #ifdef __VERBOSE 01224 write(nulprt,*) '| | | Leaving - - prism_write_mask' 01225 write(nulprt,*) ' ' 01226 CALL FLUSH(nulprt) 01227 #endif 01228 01229 RETURN 01230 01231 END SUBROUTINE prism_write_mask 01232 !-------------------------------------------------------------------------- 01233 ! 01234 SUBROUTINE prism_write_area(cgrid, nx, ny, area) 01235 !-------------------------------------------------------------------------- 01236 ! Routine to create a new areas file or to add areas of a grid to an 01237 ! existing areas file. 01238 !-------------------------------------------------------------------------- 01239 #if defined use_comm_GSIP 01240 USE mod_gsip_model 01241 #endif 01242 IMPLICIT NONE 01243 #ifndef use_comm_GSIP 01244 #ifdef use_netCDF 01245 #include <netcdf.inc> 01246 #endif 01247 #else 01248 INTEGER :: mgi_write, il_errgsip 01249 #endif 01250 CHARACTER*4, INTENT (IN) :: cgrid ! grid acronym 01251 INTEGER(kind=ip_intwp_p), INTENT (IN) :: nx ! number of longitudes 01252 INTEGER(kind=ip_intwp_p), INTENT (IN) :: ny ! number of latitudes 01253 REAL(kind=ip_realwp_p), INTENT (IN) :: area(nx,ny) ! areas 01254 01255 INTEGER(kind=ip_intwp_p) :: iost ! i/o status 01256 INTEGER(kind=ip_intwp_p) :: nulsrf ! logical unit of areas file 01257 INTEGER(kind=ip_intwp_p) :: stat ! netcdf status 01258 INTEGER(kind=ip_intwp_p) :: ncid ! netcdf file id 01259 INTEGER(kind=ip_intwp_p) :: idx, idy ! netcdf dimension ids 01260 INTEGER(kind=ip_intwp_p) :: idsrf ! netcdf variable id 01261 INTEGER(kind=ip_intwp_p) :: dims(2) ! netcdf variable dimensions 01262 INTEGER(kind=ip_intwp_p) :: il_nftype ! netcdf type 01263 01264 LOGICAL :: existent !true if areas file is already existing 01265 LOGICAL :: srfopen !true if areas file is opened 01266 01267 CHARACTER*8 :: csrf !locator sring (binary) / variable name (netcdf) 01268 01269 !-------------------------------------------------------------------------- 01270 01271 #ifdef __VERBOSE 01272 write(nulprt,*) ' ' 01273 write(nulprt,*) '| | | Entering - - prism_write_area' 01274 write(nulprt,*) ' grid acronym: ', cgrid 01275 CALL FLUSH(nulprt) 01276 #endif 01277 01278 ! 01279 !-- Return, if areas files already exists 01280 ! 01281 IF (.NOT. gridswrite) THEN 01282 write(nulprt,*) ' ' 01283 write(nulprt,*) 'No areas writing needed' 01284 RETURN 01285 ENDIF 01286 ! 01287 #if defined use_comm_GSIP 01288 ! 01289 !-- Send flag to coupler to tell it that grids will be send 01290 il_errgsip = mgi_write (ig_gsipw, 400, 1, 'I') 01291 il_errgsip = mgi_write (ig_gsipw, cgrid, 4, 'C') 01292 il_errgsip = mgi_write (ig_gsipw, nx, 1, 'I') 01293 il_errgsip = mgi_write (ig_gsipw, ny, 1, 'I') 01294 il_errgsip = mgi_write (ig_gsipw, area, nx*ny, 'R') 01295 ! 01296 #else 01297 #ifdef use_netCDF 01298 IF (l_netcdf) THEN 01299 ! ------------- 01300 !-- netCDF format 01301 ! ------------- 01302 ! 01303 il_nftype = NF_DOUBLE 01304 IF (ll_single) il_nftype = NF_REAL 01305 ! 01306 ! open areas file 01307 ! --------------- 01308 stat = NF_OPEN(csurnam//'.nc', NF_WRITE, ncid) 01309 IF (stat /= NF_NOERR) THEN 01310 stat = NF_CREATE(csurnam//'.nc', NF_CLOBBER, ncid) 01311 IF (stat /= NF_NOERR) THEN 01312 WRITE (nulprt,*) 'prism_write_area: error opening areas file.' 01313 WRITE (nulprt,*) 'prism_write_area: STOP' 01314 STOP 01315 ENDIF 01316 ENDIF 01317 ! 01318 !-- define dimensions 01319 ! ----------------- 01320 stat = NF_REDEF(ncid) 01321 stat = NF_INQ_DIMID(ncid, 'x_'//cgrid, idx) 01322 IF (stat .NE. NF_NOERR) THEN 01323 stat = NF_DEF_DIM(ncid, 'x_'//cgrid, nx, idx) 01324 IF (stat /= NF_NOERR) THEN 01325 WRITE (nulprt,*) 'ERROR defining dimension x_',cgrid 01326 ENDIF 01327 ELSE 01328 WRITE(nulprt,*)'Areas already defined: ', cgrid 01329 RETURN 01330 ENDIF 01331 stat = NF_DEF_DIM(ncid, 'y_'//cgrid, ny, idy) 01332 IF (stat /= NF_NOERR) THEN 01333 WRITE (nulprt,*) 'ERROR defining dimension y_',cgrid 01334 ENDIF 01335 01336 dims(1) = idx 01337 dims(2) = idy 01338 ! 01339 !-- define areas 01340 ! ------------ 01341 csrf=cgrid//csursuf 01342 stat = NF_DEF_VAR (ncid, csrf , il_nftype, 2, dims, idsrf) 01343 IF (stat /= NF_NOERR) THEN 01344 WRITE (nulprt,*) 'ERROR defining variable ', csrf 01345 ENDIF 01346 stat = NF_PUT_ATT_TEXT(ncid,idsrf,'long_name',13,'Areas of '//cgrid) 01347 IF (stat /= NF_NOERR) THEN 01348 WRITE (nulprt,*) 'ERROR creating att. for areas of ', cgrid 01349 ENDIF 01350 stat = NF_PUT_ATT_TEXT(ncid, idsrf, 'units', 2, 'm2') 01351 IF (stat /= NF_NOERR) THEN 01352 WRITE (nulprt,*) 'ERROR creating att. for areas of ', cgrid 01353 ENDIF 01354 ! 01355 !-- switch to data mode 01356 ! ------------------- 01357 stat = NF_ENDDEF(ncid) 01358 IF (stat /= NF_NOERR) THEN 01359 WRITE (nulprt,*) 'ERROR: file ', ncid, ' still in define mode' 01360 ENDIF 01361 ! 01362 !-- write areas 01363 ! ----------- 01364 IF (ll_single) THEN 01365 stat = NF_PUT_VAR_REAL (ncid, idsrf, area(:,:)) 01366 ELSE 01367 stat = NF_PUT_VAR_DOUBLE (ncid, idsrf, area(:,:)) 01368 ENDIF 01369 IF (stat /= NF_NOERR) THEN 01370 WRITE (nulprt,*) 'ERROR writing area of ', cgrid 01371 ENDIF 01372 ! 01373 !-- close areas file 01374 ! ---------------- 01375 stat = NF_CLOSE(ncid) 01376 IF (stat /= NF_NOERR) THEN 01377 WRITE (nulprt,*) 'ERROR closing file', csurnam 01378 ENDIF 01379 01380 ELSE 01381 #endif 01382 ! ------------- 01383 !-- binary format 01384 ! ------------- 01385 ! 01386 ! open areas file 01387 ! --------------- 01388 INQUIRE (FILE = csurnam, EXIST = existent, OPENED = srfopen) 01389 IF (existent .AND. srfopen) THEN 01390 WRITE (nulprt,*) ' ' 01391 WRITE (nulprt,*) 'prism_write_area: areas file already opened' 01392 WRITE (nulprt,*) 'prism_write_area: STOP' 01393 STOP 01394 ENDIF 01395 iost = 0 01396 nulsrf = 7 01397 INQUIRE (nulsrf,OPENED = srfopen) 01398 DO WHILE (srfopen) 01399 nulsrf = nulsrf + 1 01400 INQUIRE (nulsrf,OPENED = srfopen) 01401 END DO 01402 01403 OPEN (UNIT=nulsrf, FILE=csurnam, STATUS='UNKNOWN', & 01404 ACCESS='SEQUENTIAL', FORM='UNFORMATTED', POSITION='APPEND', & 01405 ACTION='WRITE', IOSTAT=iost, ERR=110) 01406 01407 110 CONTINUE 01408 IF (iost /= 0) THEN 01409 WRITE (nulprt,*) ' ' 01410 WRITE (nulprt,*) 'prism_write_area: Error opening areas file' 01411 WRITE (nulprt,*) 'prism_write_area: STOP' 01412 STOP 01413 ENDIF 01414 01415 ! write areas 01416 ! ----------- 01417 csrf=cgrid//csursuf 01418 WRITE (UNIT = nulsrf) csrf 01419 WRITE (UNIT = nulsrf) area(:,:) 01420 01421 ! close areas file 01422 ! ---------------- 01423 CLOSE (nulsrf) 01424 #ifdef use_netCDF 01425 ENDIF 01426 #endif 01427 #endif 01428 #ifdef __VERBOSE 01429 write(nulprt,*) '| | | Leaving - - prism_write_area' 01430 write(nulprt,*) ' ' 01431 CALL FLUSH(nulprt) 01432 #endif 01433 01434 RETURN 01435 01436 END SUBROUTINE prism_write_area 01437 01438 !-------------------------------------------------------------------------- 01439 ! 01440 SUBROUTINE prism_terminate_grids_writing 01441 !-------------------------------------------------------------------------- 01442 ! Routine to terminate the grids writing. Sent a message to OASIS 01443 ! saying that the model has written all grids and that 01444 ! the next model can start editing the grids file. 01445 !-------------------------------------------------------------------------- 01446 #if defined use_comm_GSIP 01447 USE mod_gsip_model 01448 #endif 01449 IMPLICIT NONE 01450 #ifdef use_comm_GSIP 01451 INTEGER :: mgi_write, mgi_read, il_errgsip 01452 #endif 01453 INTEGER(kind=ip_intwp_p) :: grids_done ! flag to state that grids 01454 ! writing is done 01455 INTEGER(kind=ip_intwp_p) :: dest ! rank of the receiving process 01456 01457 !-------------------------------------------------------------------------- 01458 #ifdef __VERBOSE 01459 write(nulprt,*) ' ' 01460 write(nulprt,*) '| | | Entering - - prism_terminate_grids_writing' 01461 CALL FLUSH(nulprt) 01462 #endif 01463 01464 IF (.NOT. gridswrite) THEN 01465 write(nulprt,*) ' ' 01466 write(nulprt,*) 'call to routine not needed' 01467 RETURN 01468 ENDIF 01469 01470 grids_done = 1 01471 dest = 0 ! OASIS: process 0 of global communicator 01472 01473 WRITE (nulprt,FMT='(A)') 'Send - grids_done' 01474 len = 1 01475 #if defined use_comm_MPI1 || defined use_comm_MPI2 01476 type = MPI_INTEGER 01477 tag = itagcol+13 01478 CALL MPI_Send (grids_done, len, type, dest, tag, mpi_comm, mpi_err) 01479 IF (mpi_err == MPI_SUCCESS) THEN 01480 WRITE(nulprt,FMT='(A,I2,A,I6,A,I2,A,I3,A,I5,A,I1)') & 01481 'Send - <dest:',dest,'> <comm:',mpi_comm,'> <len:',len, & 01482 '> <type:',type,'> <tag:',tag,'> :: ',grids_done 01483 ELSE 01484 WRITE (nulprt,*) ' ' 01485 WRITE (nulprt,*) 'terminate_grids_writing: an error occured' 01486 WRITE (nulprt,*) 'terminate_grids_writing: err= ', mpi_err 01487 WRITE (nulprt,*) 'terminate_grids_writing: STOP' 01488 CALL FLUSH(nulprt) 01489 STOP 01490 ENDIF 01491 #elif defined use_comm_GSIP 01492 ! 01493 ! Write grids_done in channel 01494 !c 01495 il_errgsip = mgi_write (ig_gsipw, grids_done, len, 'I') 01496 IF (il_errgsip .GE. 0) THEN 01497 WRITE(UNIT = nulprt,FMT = *) 'prism_grid_writing - GSIP grids_done OK:', grids_done 01498 ELSE 01499 WRITE(UNIT = nulprt,FMT = *) 'prism_grid_writing - GSIP grids_done not OK:', il_errgsip 01500 CALL prism_abort_proto (ig_mynummod, 'prism_terminate_grids_writing', & 01501 'GSIP grids_done not written OK in channel') 01502 ENDIF 01503 #endif 01504 #ifdef __VERBOSE 01505 write(nulprt,*) '| | | Leaving - - prism_terminate_grids_writing' 01506 write(nulprt,*) ' ' 01507 CALL FLUSH(nulprt) 01508 #endif 01509 01510 RETURN 01511 END SUBROUTINE prism_terminate_grids_writing 01512 !-------------------------------------------------------------------------- 01513 01514 END MODULE mod_prism_grids_writing 01515 !-------------------------------------------------------------------------- 01516 01517 01518
1.7.4 
