|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
00001 module mod_prism_get_proto 00002 #include "psmile_os.h" 00003 00004 interface prism_get_proto 00005 00006 #ifndef __NO_4BYTE_REALS 00007 module procedure prism_get_proto_r14 00008 module procedure prism_get_proto_r24 00009 #endif 00010 module procedure prism_get_proto_r18, & 00011 prism_get_proto_r28 00012 00013 end interface 00014 00015 contains 00016 00017 SUBROUTINE prism_get_proto_r14(id_port_id,kstep,rd_field,kinfo) 00018 ! 00019 !* *** PRISM_get *** PRISM 1.0 00020 ! 00021 ! purpose: 00022 ! -------- 00023 ! recv pfield from oasis or models connected to port id_port_id 00024 ! 00025 ! interface: 00026 ! ---------- 00027 ! id_port_id : port number of the field 00028 ! kstep : current time in seconds 00029 ! pfield : buffer of reals 00030 ! kinfo : output status 00031 ! 00032 ! lib mp: 00033 ! ------- 00034 ! mpi-1 or mpi-2 or gsip 00035 ! 00036 ! author: 00037 ! ------- 00038 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import) 00039 ! 00040 ! modified: 00041 ! --------- 00042 ! Reiner Vogelsang, SGI, 27 April 2003 00043 ! - Screening of 4 byte real interfaces in case a of dbl4 compilation. 00044 ! File has to be preprocessed with -D__SXdbl4. 00045 ! S. Legutke, MPI M&D (05/03 - kinfo = PRISM_Recvd added) 00046 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 00047 ! 00048 !--------------------------------------------------------------------- 00049 USE mod_kinds_model 00050 USE mod_prism_proto 00051 USE mod_comprism_proto 00052 #if defined use_comm_GSIP 00053 USE mod_gsip_model 00054 #endif 00055 IMPLICIT none 00056 #if defined use_comm_MPI1 || defined use_comm_MPI2 00057 #include <mpif.h> 00058 INTEGER(kind=ip_intwp_p) istatus(MPI_STATUS_SIZE) 00059 #endif 00060 ! ---------------------------------------------------------------- 00061 INTEGER(kind=ip_intwp_p), intent(in) :: id_port_id,kstep 00062 INTEGER(kind=ip_intwp_p), intent(out) :: kinfo 00063 REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)), intent(inout) :: rd_field 00064 ! ---------------------------------------------------------------- 00065 INTEGER(kind=ip_intwp_p) info, ip, iport 00066 INTEGER(kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb 00067 INTEGER(kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt 00068 INTEGER(kind=ip_intwp_p) iposbuf, imaxbyt 00069 #if defined __DEBUG 00070 INTEGER(kind=ip_intwp_p) icount 00071 INTEGER(kind=ip_intwp_p), parameter :: icountmax=600 00072 LOGICAL :: iflag 00073 #endif 00074 #ifdef use_comm_GSIP 00075 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 00076 INTEGER :: mgi_read 00077 #endif 00078 #ifdef balance 00079 CHARACTER(8) :: date 00080 CHARACTER(10) :: time 00081 CHARACTER(5) :: zone 00082 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 00083 REAL(kind=ip_double_p):: millisec 00084 REAL(kind=ip_double_p):: sec_date 00085 #endif 00086 ! ---------------------------------------------------------------- 00087 ! 00088 #ifdef __VERBOSE 00089 WRITE(nulprt,*) ' ' 00090 WRITE(nulprt,*) '| | | Entering prism_get_proto_r14 for field ', id_port_id 00091 call flush(nulprt) 00092 #endif 00093 ! 00094 #if defined use_comm_MPI1 || defined use_comm_MPI2 00095 istatus(:)=0 00096 #endif 00097 00098 !* 0. Entering 00099 ! ----------- 00100 ! 00101 kinfo = PRISM_Ok 00102 ! 00103 !* 1. check for this port in my list 00104 ! --------------------------------- 00105 ! 00106 irecv = 0 00107 iport = -1 00108 ! 00109 ! Test if the field is defined in the namcouple and if its coupling period 00110 ! is not greater than the time of the simulation. 00111 IF (ig_def_freq(id_port_id) .eq. 0 .or. & 00112 ig_def_freq(id_port_id) .gt. ig_ntime .or. & 00113 ig_def_state(id_port_id) .eq. ip_auxilary) THEN 00114 GOTO 1010 00115 ENDIF 00116 IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id 00117 IF (iport.lt.0) THEN 00118 kinfo = CLIM_BadPort 00119 WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', & 00120 cports(id_port_id) 00121 GO TO 1010 00122 ENDIF 00123 ! 00124 !* Test if the current time is a coupling (or I/O) time 00125 ! 00126 IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN 00127 ! 00128 !* If the user indicated in the namcouple that the field is 00129 !* a field input-from-file (keyword 'INPUT' at the end of the 00130 !* field 1st line), do the reading from file here, e.g.: 00131 ! 00132 #if !defined key_noIO 00133 IF (ig_def_state(iport) .EQ. ip_input) THEN 00134 CALL psmile_read_4(iport,rd_field,kstep) 00135 kinfo = PRISM_Input 00136 ENDIF 00137 #endif 00138 ! 00139 !* Define return code (direct or via Oasis does not matter) 00140 ! 00141 IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN 00142 kinfo = PRISM_FromRest 00143 #if !defined key_noIO 00144 IF (ig_def_state(iport) .EQ. ip_ignout .OR. & 00145 ig_def_state(iport) .EQ. ip_expout) THEN 00146 kinfo = PRISM_FromRestOut 00147 ENDIF 00148 #endif 00149 ELSE 00150 IF (ig_def_state(iport) .NE. ip_input) THEN 00151 kinfo = PRISM_Recvd 00152 ! 00153 #if !defined key_noIO 00154 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 00155 ig_def_state(iport) .EQ. ip_ignout) THEN 00156 kinfo = PRISM_RecvOut 00157 ENDIF 00158 #endif 00159 ENDIF 00160 ENDIF 00161 ! 00162 IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. & 00163 (ig_def_state(iport) .eq. ip_ignored .or. & 00164 ig_def_state(iport) .eq. ip_ignout)) THEN 00165 ! 00166 !* Note: A model can have several restart files but same restart 00167 !* file can't be used by different models 00168 !* Test if model is serial or parallel and if variables are real 00169 ! or double precision 00170 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 00171 call read_filer4(rd_field, cports(iport),iport) 00172 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 00173 ELSE 00174 call read_file_parar4(rd_field, cports(iport),iport) 00175 #endif 00176 ENDIF 00177 #if !defined key_noIO 00178 IF (ig_def_state(iport) .EQ. ip_ignout) & 00179 CALL psmile_write_4(iport,rd_field,kstep) 00180 #endif 00181 ELSE 00182 !* 00183 !* If the user indicated in the namcouple that the field is 00184 !* a coupling field then do the import : 00185 IF (ig_def_state(iport) .ne. ip_output .and. & 00186 ig_def_state(iport) .ne. ip_input) THEN 00187 ! 00188 !* Check for connected ports (in) 00189 ! ------------------------------ 00190 ! 00191 #ifdef __VERBOSE 00192 WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport) 00193 call flush(nulprt) 00194 #endif 00195 ! 00196 ityp = myport(2,iport) 00197 ibyt = myport(3,iport) 00198 ! 00199 #ifdef balance 00200 CALL date_and_time(date,time,zone,values) 00201 millisec=values(8) 00202 sec_date=millisec/1000+values(7)+values(6)*60+& 00203 values(5)*3600+values(3)*86400 00204 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00205 'Balance: ',cports(iport),'Before MPI get ',sec_date 00206 #endif 00207 DO ip=1,myport(5,iport) 00208 ! 00209 ilk = myport(5+ip,iport) 00210 imod = mylink(1,ilk) 00211 itid = mylink(2,ilk) 00212 itag = mylink(3,ilk) - kstep / ig_frqmin 00213 iseg = mylink(4,ilk) 00214 ! 00215 !* Implementation with "blocking" receives : the program will wait 00216 !* indefinitely until a message is received (this may generate a 00217 !* deadlock if all models are waiting on a receive). 00218 !* However this method will be more efficient in most cases than the 00219 !* receives with a time-out loop. 00220 ! 00221 #if defined use_comm_MPI1 || use_comm_MPI2 00222 #ifdef __DEBUG 00223 !jl 00224 !jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox 00225 !jl exist in the network (2004-04-28) 00226 !jl Also, allows to check the timing of the receives of messages 00227 !jl For completion, the same syntax should be added in oasis "Getfld" 00228 !jl 00229 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 00230 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 00231 ' comm = ',mpi_comm,' result is : ',iflag 00232 call flush(nulprt) 00233 00234 IF (.NOT.iflag) THEN 00235 icount = 0 00236 WAITLOOP: DO 00237 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 00238 icount = icount + 1 00239 IF ( iflag ) EXIT WAITLOOP 00240 IF ( icount .GE. icountmax ) THEN 00241 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 00242 ' still negative after ',icountmax,' seconds : Abort the job' 00243 call flush(nulprt) 00244 CALL MPI_ABORT (mpi_comm, 0, mpi_err) 00245 ENDIF 00246 call sleep(1) 00247 END DO WAITLOOP 00248 WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount 00249 call flush(nulprt) 00250 ENDIF 00251 #endif 00252 !jl 00253 CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, & 00254 itid, itag, mpi_comm, istatus, info ) 00255 CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, & 00256 info ) 00257 ! 00258 IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN 00259 ilgb = 0 00260 iposbuf = 0 00261 DO is=1,iseg 00262 ioff = mylink(4+2*is-1,ilk) * 2 + 1 00263 il_len = mylink(4+2*is,ilk) 00264 ! 00265 IF ( ityp .EQ. PRISM_Real ) THEN 00266 CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, & 00267 iposbuf, rd_field(ioff), il_len, & 00268 MPI_REAL, mpi_comm, info) 00269 ELSE 00270 WRITE(nulprt,*)'Get - pb type incorrect ',ityp 00271 kinfo = CLIM_BadType 00272 GO TO 1010 00273 ENDIF 00274 ilgb = ilgb + il_len 00275 ENDDO 00276 IF (ilgb*ibyt .le. imaxbyt) THEN 00277 irecv = irecv + 1 00278 nbrecv = nbrecv + ilgb * ibyt 00279 #ifdef __VERBOSE 00280 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 00281 'Get - <from:',imod, & 00282 '> <step:',kstep, & 00283 '> <len:',ilgb, & 00284 '> <type:',ibyt, & 00285 '> <tag:',itag,'>' 00286 CALL FLUSH(nulprt) 00287 #endif 00288 ELSE 00289 kinfo = CLIM_Unpack 00290 WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', & 00291 info,'>' 00292 GO TO 1010 00293 ENDIF 00294 ELSE 00295 kinfo = CLIM_TimeOut 00296 WRITE(nulprt,FMT='(A,I3,A)') & 00297 'Get - abnormal exit from trecv <mpi ',info,'>' 00298 GO TO 1010 00299 ENDIF 00300 ! 00301 #elif defined use_comm_GSIP 00302 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 00303 (0,'prism_get_proto', 'STOP -- only one reception from Oasis, myport(5,iport) should be 1') 00304 if (imod .ne. 0) CALL prism_abort_proto & 00305 (0,'prism_get_proto', 'STOP -- if received from Oasis, imod should be 0') 00306 if (itid .ne. 1) CALL prism_abort_proto & 00307 (0,'prism_get_proto', 'STOP -- if received from Oasis, itid should be 1') 00308 00309 ! 00310 ! Read info in channel from Oasis (no DIRECT communication) 00311 ! 00312 il_errgsip = mgi_read (ig_gsipr, pkworkps, ig_CLIMmax , 'R') 00313 IF (il_errgsip .GE. 0) THEN 00314 WRITE(UNIT = nulprt,FMT = *) & 00315 'prism_get_proto - pkworkps read OK:', il_errgsip 00316 call flush(nulprt) 00317 ELSE 00318 WRITE(UNIT = nulprt,FMT = *) & 00319 '1- prism_get_proto - error :', il_errgsip 00320 call flush(nulprt) 00321 CALL prism_abort_proto (0, 'prism_get_proto', & 00322 'STOP - pkworkps not read OK)') 00323 ENDIF 00324 ! 00325 ! Fill rd_field with segments of pkworkps 00326 ilgb = 0 00327 il_rst = 0 00328 il_ren = 0 00329 DO is=1,iseg 00330 ioff = mylink(4+2*is-1,ilk) + 1 00331 il_len = mylink(4+2*is,ilk) 00332 il_rst = il_ren + 1 00333 il_ren = il_rst + il_len - 1 00334 rd_field(ioff:ioff+il_len-1) = pkworkps(il_rst:il_ren) 00335 ! 00336 ilgb = ilgb + il_len 00337 ENDDO 00338 IF (ilgb .LE. ig_CLIMmax) THEN 00339 irecv = irecv + 1 00340 #ifdef __VERBOSE 00341 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 00342 'Get - <from:',imod, '> <step:',kstep, & 00343 '> <len:',ilgb, '> <type:',ibyt, '> <tag:',itid,'>' 00344 CALL FLUSH(nulprt) 00345 #endif 00346 ELSE 00347 WRITE(UNIT = nulprt,FMT = *) & 00348 '2- prism_get_proto - error :', il_errgsip 00349 CALL prism_abort_proto (0, 'prism_get_proto', & 00350 'STOP - sum of segments greater than pkworkps size') 00351 ENDIF 00352 #endif 00353 ENDDO 00354 #ifdef balance 00355 CALL date_and_time(date,time,zone,values) 00356 millisec=values(8) 00357 sec_date=millisec/1000+values(7)+values(6)*60+& 00358 values(5)*3600+values(3)*86400 00359 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00360 'Balance: ',cports(iport),'After MPI get ',sec_date 00361 #endif 00362 ! 00363 #ifdef __VERBOSE 00364 WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported' 00365 call flush(nulprt) 00366 #endif 00367 ! 00368 #if !defined key_noIO 00369 ! 00370 !* If the user indicated in the namcouple that the field must be written 00371 !* to file, do the writing here : 00372 ! 00373 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 00374 ig_def_state(iport) .EQ. ip_ignout) THEN 00375 CALL psmile_write_4(iport,rd_field,kstep) 00376 ENDIF 00377 #endif 00378 ENDIF 00379 ENDIF 00380 ENDIF 00381 ! 00382 ! ---------------------------------------------------------------- 00383 ! 00384 1010 CONTINUE 00385 ! 00386 #ifdef __VERBOSE 00387 WRITE(nulprt,*)'| | | Leaving routine prism_get_proto_r14' 00388 WRITE(nulprt,*) ' ' 00389 CALL FLUSH(nulprt) 00390 #endif 00391 ! 00392 RETURN 00393 END SUBROUTINE prism_get_proto_r14 00394 00395 SUBROUTINE prism_get_proto_r18(id_port_id,kstep,rd_field,kinfo) 00396 ! 00397 !* *** PRISM_get *** PRISM 1.0 00398 ! 00399 ! purpose: 00400 ! -------- 00401 ! recv pfield from oasis or models connected to port id_port_id 00402 ! 00403 ! interface: 00404 ! ---------- 00405 ! id_port_id : port number of the field 00406 ! kstep : current time in seconds 00407 ! rd_field : buffer of reals 00408 ! kinfo : output status 00409 ! 00410 ! lib mp: 00411 ! ------- 00412 ! mpi-1 or mpi-2 or gsip 00413 ! 00414 ! author: 00415 ! ------- 00416 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import) 00417 ! S. Legutke, - MPI M&D (05/03 - kinfo = PRISM_Recvd added) 00418 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 00419 ! 00420 ! ---------------------------------------------------------------- 00421 USE mod_kinds_model 00422 USE mod_prism_proto 00423 USE mod_comprism_proto 00424 #if defined use_comm_GSIP 00425 USE mod_gsip_model 00426 #endif 00427 IMPLICIT none 00428 #if defined use_comm_MPI1 || defined use_comm_MPI2 00429 #include <mpif.h> 00430 INTEGER (kind=ip_intwp_p) istatus(MPI_STATUS_SIZE) 00431 #endif 00432 ! ---------------------------------------------------------------- 00433 INTEGER (kind=ip_intwp_p), intent(in) :: id_port_id,kstep 00434 INTEGER (kind=ip_intwp_p), intent(out) :: kinfo 00435 REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)), intent(inout) :: rd_field 00436 ! ---------------------------------------------------------------- 00437 INTEGER (kind=ip_intwp_p) info, ip, iport 00438 INTEGER (kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb 00439 INTEGER (kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt 00440 INTEGER (kind=ip_intwp_p) iposbuf, imaxbyt 00441 #if defined __DEBUG 00442 INTEGER(kind=ip_intwp_p) icount 00443 INTEGER(kind=ip_intwp_p), parameter :: icountmax=600 00444 LOGICAL :: iflag 00445 #endif 00446 #ifdef use_comm_GSIP 00447 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 00448 INTEGER :: mgi_read 00449 #endif 00450 #ifdef balance 00451 CHARACTER(8) :: date 00452 CHARACTER(10) :: time 00453 CHARACTER(5) :: zone 00454 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 00455 REAL(kind=ip_double_p):: millisec 00456 REAL(kind=ip_double_p):: sec_date 00457 #endif 00458 ! ---------------------------------------------------------------- 00459 ! 00460 #ifdef __VERBOSE 00461 WRITE(nulprt,*) ' ' 00462 WRITE(nulprt,*) '| | | Entering prism_get_proto_r18 for field ',id_port_id 00463 call flush(nulprt) 00464 #endif 00465 ! 00466 #if defined use_comm_MPI1 || defined use_comm_MPI2 00467 istatus(:)=0 00468 #endif 00469 ! 00470 !* 0. Entering 00471 ! -------------- 00472 ! 00473 kinfo = PRISM_Ok 00474 ! 00475 !* 1. check for this port in my list 00476 ! --------------------------------- 00477 ! 00478 irecv = 0 00479 iport = -1 00480 ! 00481 ! Test if the field is defined in the namcouple and if its coupling period 00482 ! is not greater than the time of the simulation. 00483 IF (ig_def_freq(id_port_id) .eq. 0 .or. & 00484 ig_def_freq(id_port_id) .gt. ig_ntime .or. & 00485 ig_def_state(id_port_id) .eq. ip_auxilary) THEN 00486 GOTO 1010 00487 ENDIF 00488 IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id 00489 IF (iport.lt.0) THEN 00490 kinfo = CLIM_BadPort 00491 WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', & 00492 cports(id_port_id) 00493 GO TO 1010 00494 ENDIF 00495 ! 00496 !* Test if the current time is a coupling (or I/O) time 00497 ! 00498 IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN 00499 ! 00500 #ifdef __VERBOSE 00501 WRITE(nulprt,*) 'Current time is a coupling (or I/O) time' 00502 WRITE(nulprt,*) 'for field with status =', ig_def_state(iport) 00503 CALL FLUSH(nulprt) 00504 #endif 00505 ! 00506 !* If the user indicated in the namcouple that the field is 00507 !* a field input-from-file (keyword 'INPUT' at the end of the 00508 !* field 1st line), do the reading from file here, e.g.: 00509 ! 00510 #if !defined key_noIO 00511 IF (ig_def_state(iport) .eq. ip_input) then 00512 WRITE(nulprt,*) 'Get - Input field' 00513 CALL psmile_read_8(iport,rd_field,kstep) 00514 kinfo = PRISM_Input 00515 ENDIF 00516 #endif 00517 ! 00518 !* Define return code (direct or via Oasis does not matter) 00519 ! 00520 IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN 00521 kinfo = PRISM_FromRest 00522 #if !defined key_noIO 00523 IF (ig_def_state(iport) .EQ. ip_ignout .OR. & 00524 ig_def_state(iport) .EQ. ip_expout) THEN 00525 kinfo = PRISM_FromRestOut 00526 ENDIF 00527 #endif 00528 ELSE 00529 IF (ig_def_state(iport) .NE. ip_input) THEN 00530 kinfo = PRISM_Recvd 00531 ! 00532 #if !defined key_noIO 00533 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 00534 ig_def_state(iport) .EQ. ip_ignout) THEN 00535 kinfo = PRISM_RecvOut 00536 ENDIF 00537 #endif 00538 ENDIF 00539 ENDIF 00540 ! 00541 !* Test if first import and if the user indicated in the 00542 !* namcouple that the field is exchanged directly 00543 !* between the models and not treated by Oasis 00544 !* (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line), 00545 !* do the reading from restart file (not implemented). 00546 ! 00547 IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. & 00548 (ig_def_state(iport) .eq. ip_ignored .or. & 00549 ig_def_state(iport) .eq. ip_ignout)) THEN 00550 ! 00551 !* Note: A model can have several restart files but same restart 00552 !* file can't be used by different models 00553 !* Test if model is serial or parallel and if variables are real 00554 ! or double precision 00555 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 00556 call read_filer8(rd_field, cports(iport),iport) 00557 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 00558 ELSE 00559 call read_file_parar8(rd_field, cports(iport),iport) 00560 #endif 00561 ENDIF 00562 #if !defined key_noIO 00563 IF (ig_def_state(iport) .EQ. ip_ignout) & 00564 CALL psmile_write_8(iport,rd_field,kstep) 00565 #endif 00566 ELSE 00567 !* 00568 !* If the user indicated in the namcouple that the field is 00569 !* a coupling field then do the import : 00570 ! 00571 IF (ig_def_state(iport) .ne. ip_output .and. & 00572 ig_def_state(iport) .ne. ip_input) THEN 00573 ! 00574 !* Check for connected ports (in) 00575 ! ------------------------------ 00576 ! 00577 #ifdef __VERBOSE 00578 WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport) 00579 CALL FLUSH(nulprt) 00580 #endif 00581 ! 00582 ityp = myport(2,iport) 00583 ibyt = myport(3,iport) 00584 ! 00585 #ifdef balance 00586 CALL date_and_time(date,time,zone,values) 00587 millisec=values(8) 00588 sec_date=millisec/1000+values(7)+values(6)*60+& 00589 values(5)*3600+values(3)*86400 00590 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00591 'Balance: ',cports(iport),'Before MPI get ',sec_date 00592 #endif 00593 DO ip=1,myport(5,iport) 00594 ! 00595 ilk = myport(5+ip,iport) 00596 imod = mylink(1,ilk) 00597 itid = mylink(2,ilk) 00598 itag = mylink(3,ilk) - kstep / ig_frqmin 00599 iseg = mylink(4,ilk) 00600 ! 00601 !* Implementation with "blocking" receives : the program will wait 00602 !* indefinitely until a message is received (this may generate a 00603 !* deadlock if all models are waiting on a receive). 00604 !* However this method will be more efficient in most cases than the 00605 !* receives with a time-out loop. 00606 ! 00607 ! 00608 #if defined use_comm_MPI1 || defined use_comm_MPI2 00609 #if defined __DEBUG 00610 !jl 00611 !jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox 00612 !jl exist in the network (2004-04-28) 00613 !jl 00614 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 00615 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 00616 ' comm = ',mpi_comm,' result is : ',iflag 00617 call flush(nulprt) 00618 00619 IF (.NOT.iflag) THEN 00620 icount = 0 00621 WAITLOOP: DO 00622 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 00623 icount = icount + 1 00624 IF ( iflag ) EXIT WAITLOOP 00625 IF ( icount .GE. icountmax ) THEN 00626 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 00627 ' still negative after ',icountmax,' seconds : Abort the job' 00628 call flush(nulprt) 00629 CALL MPI_ABORT (mpi_comm, 0, mpi_err) 00630 ENDIF 00631 call sleep(1) 00632 END DO WAITLOOP 00633 WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount 00634 call flush(nulprt) 00635 ENDIF 00636 #endif 00637 !jl 00638 CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, & 00639 itid, itag, mpi_comm, istatus, info ) 00640 CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, & 00641 info ) 00642 ! 00643 IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN 00644 ilgb = 0 00645 iposbuf = 0 00646 DO is=1,iseg 00647 ioff = mylink(4+2*is-1,ilk) + 1 00648 il_len = mylink(4+2*is,ilk) 00649 ! 00650 IF ( ityp .EQ. PRISM_Real ) THEN 00651 CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, & 00652 iposbuf, rd_field(ioff), il_len, & 00653 MPI_DOUBLE_PRECISION, mpi_comm, info) 00654 ELSE 00655 WRITE(nulprt,*)'Get - pb type incorrect ',ityp 00656 kinfo = CLIM_BadType 00657 GO TO 1010 00658 ENDIF 00659 ilgb = ilgb + il_len 00660 ENDDO 00661 IF (ilgb*ibyt .le. imaxbyt) THEN 00662 irecv = irecv + 1 00663 nbrecv = nbrecv + ilgb * ibyt 00664 #ifdef __VERBOSE 00665 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 00666 'Get - <from:',itid, & 00667 '> <step:',kstep, & 00668 '> <len:',ilgb, & 00669 '> <type:',ibyt, & 00670 '> <tag:',itag,'>' 00671 CALL flush(nulprt) 00672 #endif 00673 ELSE 00674 kinfo = CLIM_Unpack 00675 WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', & 00676 info,'>' 00677 GO TO 1010 00678 ENDIF 00679 ELSE 00680 kinfo = CLIM_TimeOut 00681 WRITE(nulprt,FMT='(A,I3,A)') & 00682 'Get - abnormal exit from trecv <mpi ',info,'>' 00683 GO TO 1010 00684 ENDIF 00685 ! 00686 #elif defined use_comm_GSIP 00687 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 00688 (0,'prism_get_proto', 'STOP -- only one reception from Oasis, myport(5,iport) should be 1') 00689 if (imod .ne. 0) CALL prism_abort_proto & 00690 (0,'prism_get_proto', 'STOP -- if received from Oasis, imod should be 0') 00691 if (itid .ne. 1) CALL prism_abort_proto & 00692 (0,'prism_get_proto', 'STOP -- if received from Oasis, itid should be 1') 00693 00694 ! 00695 ! Read info in channel from Oasis (no DIRECT communication) 00696 ! 00697 il_errgsip = mgi_read (ig_gsipr, pkworkps, ig_CLIMmax , 'D') 00698 IF (il_errgsip .GE. 0) THEN 00699 WRITE(UNIT = nulprt,FMT = *) & 00700 'prism_get_proto - pkworkps read OK:', il_errgsip 00701 ELSE 00702 WRITE(UNIT = nulprt,FMT = *) & 00703 '1- prism_get_proto - error :', il_errgsip 00704 CALL prism_abort_proto (0, 'prism_get_proto', & 00705 'STOP - pkworkps not read OK)') 00706 ENDIF 00707 ! 00708 ! Fill rd_field with segments of pkworkps 00709 ilgb = 0 00710 il_rst = 0 00711 il_ren = 0 00712 DO is=1,iseg 00713 ioff = mylink(4+2*is-1,ilk) + 1 00714 il_len = mylink(4+2*is,ilk) 00715 il_rst = il_ren + 1 00716 il_ren = il_rst + il_len - 1 00717 rd_field(ioff:ioff+il_len-1) = pkworkps(il_rst:il_ren) 00718 ! 00719 ilgb = ilgb + il_len 00720 ENDDO 00721 IF (ilgb .LE. ig_CLIMmax) THEN 00722 irecv = irecv + 1 00723 #ifdef __VERBOSE 00724 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 00725 'Get - <from:',imod, '> <step:',kstep, & 00726 '> <len:',ilgb, '> <type:',ibyt, '> <tag:',itid,'>' 00727 CALL FLUSH(nulprt) 00728 #endif 00729 ELSE 00730 WRITE(UNIT = nulprt,FMT = *) & 00731 '2- prism_get_proto - error :', il_errgsip 00732 CALL prism_abort_proto (0, 'prism_get_proto', & 00733 'STOP - sum of segments greater than pkworkps size') 00734 ENDIF 00735 #endif 00736 ENDDO 00737 #ifdef balance 00738 CALL date_and_time(date,time,zone,values) 00739 millisec=values(8) 00740 sec_date=millisec/1000+values(7)+values(6)*60+& 00741 values(5)*3600+values(3)*86400 00742 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00743 'Balance: ',cports(iport),'After MPI get ',sec_date 00744 #endif 00745 ! 00746 #ifdef __VERBOSE 00747 WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported' 00748 CALL FLUSH(nulprt) 00749 #endif 00750 ! 00751 #if !defined key_noIO 00752 ! 00753 !* If the user indicated in the namcouple that the field must be written 00754 !* to file, do the writing here : 00755 ! 00756 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 00757 ig_def_state(iport) .EQ. ip_ignout) THEN 00758 CALL psmile_write_8(iport,rd_field,kstep) 00759 ENDIF 00760 #endif 00761 ENDIF 00762 ENDIF 00763 ENDIF 00764 ! 00765 ! ---------------------------------------------------------------- 00766 ! 00767 1010 CONTINUE 00768 ! 00769 #ifdef __VERBOSE 00770 WRITE(nulprt,*)'| | | Leaving routine prism_get_proto_r18' 00771 WRITE(nulprt,*) ' ' 00772 CALL FLUSH(nulprt) 00773 #endif 00774 ! 00775 RETURN 00776 END SUBROUTINE prism_get_proto_r18 00777 00778 SUBROUTINE prism_get_proto_r24(id_port_id,kstep,rd_field_2d,kinfo) 00779 ! 00780 !* *** PRISM_get *** PRISM 1.0 00781 ! 00782 ! purpose: 00783 ! -------- 00784 ! recv pfield from oasis or models connected to port id_port_id 00785 ! 00786 ! interface: 00787 ! ---------- 00788 ! id_port_id : port number of the field 00789 ! kstep : current time in seconds 00790 ! rd_field_2d : buffer of reals 00791 ! kinfo : output status 00792 ! 00793 ! lib mp: 00794 ! ------- 00795 ! mpi-1 or mpi-2 or gsip 00796 ! 00797 ! author: 00798 ! ------- 00799 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import) 00800 ! S. Legutke, - MPI M&D (05/03 - kinfo = PRISM_Recvd added) 00801 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 00802 ! ---------------------------------------------------------------- 00803 USE mod_kinds_model 00804 USE mod_prism_proto 00805 USE mod_comprism_proto 00806 #if defined use_comm_GSIP 00807 USE mod_gsip_model 00808 #endif 00809 IMPLICIT none 00810 #if defined use_comm_MPI1 || defined use_comm_MPI2 00811 #include <mpif.h> 00812 INTEGER (kind=ip_intwp_p) istatus(MPI_STATUS_SIZE) 00813 #endif 00814 ! ---------------------------------------------------------------- 00815 INTEGER (kind=ip_intwp_p), intent(in) :: id_port_id, kstep 00816 INTEGER (kind=ip_intwp_p), intent(out) :: kinfo 00817 REAL(kind=ip_single_p), DIMENSION(:,:), intent(inout) :: rd_field_2d 00818 ! ---------------------------------------------------------------- 00819 REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field 00820 INTEGER (kind=ip_intwp_p) info, ip, iport 00821 INTEGER (kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb 00822 INTEGER (kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt 00823 INTEGER (kind=ip_intwp_p) iposbuf, imaxbyt 00824 ! 00825 #ifdef __DEBUG 00826 INTEGER(kind=ip_intwp_p) icount 00827 INTEGER(kind=ip_intwp_p), parameter :: icountmax=600 00828 LOGICAL :: iflag 00829 #endif 00830 #ifdef use_comm_GSIP 00831 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 00832 INTEGER :: mgi_read 00833 #endif 00834 #ifdef balance 00835 CHARACTER(8) :: date 00836 CHARACTER(10) :: time 00837 CHARACTER(5) :: zone 00838 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 00839 REAL(kind=ip_double_p):: millisec 00840 REAL(kind=ip_double_p):: sec_date 00841 #endif 00842 ! ---------------------------------------------------------------- 00843 ! 00844 #ifdef __VERBOSE 00845 WRITE(nulprt,*) ' ' 00846 WRITE(nulprt,*) '| | | Entering prism_get_proto_r24 for field ',id_port_id 00847 CALL FLUSH(nulprt) 00848 #endif 00849 00850 rd_field(:)=0 00851 #if defined use_comm_MPI1 || defined use_comm_MPI2 00852 istatus(:)=0 00853 #endif 00854 ! 00855 !* 0. Entering 00856 ! -------------- 00857 ! 00858 kinfo = PRISM_Ok 00859 ! 00860 !* 1. check for this port in my list 00861 ! --------------------------------- 00862 ! 00863 irecv = 0 00864 iport = -1 00865 ! 00866 ! Test if the field is defined in the namcouple and if its coupling period 00867 ! is not greater than the time of the simulation. 00868 IF (ig_def_freq(id_port_id) .eq. 0 .or. & 00869 ig_def_freq(id_port_id) .gt. ig_ntime .or. & 00870 ig_def_state(id_port_id) .eq. ip_auxilary) THEN 00871 GOTO 1010 00872 ENDIF 00873 IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id 00874 IF (iport.lt.0) THEN 00875 kinfo = CLIM_BadPort 00876 WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', & 00877 cports(id_port_id) 00878 GO TO 1010 00879 ENDIF 00880 ! 00881 ! 00882 !* Test if the current time is a coupling (or I/O) time 00883 ! 00884 IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN 00885 ! 00886 !* If the user indicated in the namcouple that the field is 00887 !* a field input-from-file (keyword 'INPUT' at the end of the 00888 !* field 1st line), do the reading from file here, e.g.: 00889 ! 00890 #if !defined key_noIO 00891 IF (ig_def_state(iport) .EQ. ip_input) THEN 00892 CALL psmile_read_4(iport,rd_field,kstep) 00893 kinfo = PRISM_Input 00894 ENDIF 00895 #endif 00896 ! 00897 !* Define return code (direct or via Oasis does not matter) 00898 ! 00899 IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN 00900 kinfo = PRISM_FromRest 00901 #if !defined key_noIO 00902 IF (ig_def_state(iport) .EQ. ip_ignout .OR. & 00903 ig_def_state(iport) .EQ. ip_expout) THEN 00904 kinfo = PRISM_FromRestOut 00905 ENDIF 00906 #endif 00907 ELSE 00908 IF (ig_def_state(iport) .NE. ip_input) THEN 00909 kinfo = PRISM_Recvd 00910 ! 00911 #if !defined key_noIO 00912 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 00913 ig_def_state(iport) .EQ. ip_ignout) THEN 00914 kinfo = PRISM_RecvOut 00915 ENDIF 00916 #endif 00917 ENDIF 00918 ENDIF 00919 ! 00920 !* Test if first import and if the user indicated in the 00921 !* namcouple that the field is 00922 !* exchanged directly between the models and not treated by 00923 !* Oasis (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line), 00924 !* do the reading from restart file (not implemented). 00925 ! 00926 IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. & 00927 (ig_def_state(iport) .eq. ip_ignored .or. & 00928 ig_def_state(iport) .eq. ip_ignout)) THEN 00929 ! 00930 !* Note: A model can have several restart files but same restart 00931 !* file can't be used by different models 00932 !* Test if model is serial or parallel and if variables are real 00933 ! or double precision 00934 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 00935 call read_filer4(rd_field, cports(iport),iport) 00936 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 00937 ELSE 00938 call read_file_parar4(rd_field, cports(iport),iport) 00939 #endif 00940 ENDIF 00941 #if !defined key_noIO 00942 IF (ig_def_state(iport) .EQ. ip_ignout) & 00943 call psmile_write_4(iport,rd_field,kstep) 00944 #endif 00945 ELSE 00946 ! 00947 !* If the user indicated in the namcouple that the field is 00948 !* a coupling field then do the import : 00949 IF (ig_def_state(iport) .NE. ip_output .AND. & 00950 ig_def_state(iport) .ne. ip_input) THEN 00951 ! 00952 !* Check for connected ports (in) 00953 ! ------------------------------ 00954 ! 00955 #ifdef __VERBOSE 00956 WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport) 00957 CALL FLUSH(nulprt) 00958 #endif 00959 ! 00960 ityp = myport(2,iport) 00961 ibyt = myport(3,iport) 00962 ! 00963 #ifdef balance 00964 CALL date_and_time(date,time,zone,values) 00965 millisec=values(8) 00966 sec_date=millisec/1000+values(7)+values(6)*60+& 00967 values(5)*3600+values(3)*86400 00968 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00969 'Balance: ',cports(iport),'Before MPI get ',sec_date 00970 CALL FLUSH(nulprt) 00971 #endif 00972 DO ip=1,myport(5,iport) 00973 ! 00974 ilk = myport(5+ip,iport) 00975 imod = mylink(1,ilk) 00976 itid = mylink(2,ilk) 00977 itag = mylink(3,ilk) - kstep / ig_frqmin 00978 iseg = mylink(4,ilk) 00979 ! 00980 !* Implementation with "blocking" receives : the program will wait 00981 !* indefinitely until a message is received (this may generate a 00982 !* deadlock if all models are waiting on a receive). 00983 !* However this method will be more efficient in most cases than the 00984 !* receives with a time-out loop. 00985 ! 00986 #if defined use_comm_MPI1 || defined use_comm_MPI2 00987 #if defined __DEBUG 00988 ! 00989 !jl 00990 !jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox 00991 !jl exist in the network (2004-04-28) 00992 !jl 00993 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 00994 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 00995 ' comm = ',mpi_comm,' result is : ',iflag 00996 call flush(nulprt) 00997 00998 IF (.NOT.iflag) THEN 00999 icount = 0 01000 WAITLOOP: DO 01001 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 01002 icount = icount + 1 01003 IF ( iflag ) EXIT WAITLOOP 01004 IF ( icount .GE. icountmax ) THEN 01005 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 01006 ' still negative after ',icountmax,' seconds : Abort the job' 01007 call flush(nulprt) 01008 CALL MPI_ABORT (mpi_comm, 0, mpi_err) 01009 ENDIF 01010 call sleep(1) 01011 END DO WAITLOOP 01012 WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount 01013 call flush(nulprt) 01014 ENDIF 01015 #endif 01016 !jl 01017 CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, & 01018 itid, itag, mpi_comm, istatus, info ) 01019 CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, & 01020 info ) 01021 ! 01022 IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN 01023 ilgb = 0 01024 iposbuf = 0 01025 DO is=1,iseg 01026 ioff = mylink(4+2*is-1,ilk) * 2 + 1 01027 il_len = mylink(4+2*is,ilk) 01028 ! 01029 IF ( ityp .EQ. PRISM_Real ) THEN 01030 CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, & 01031 iposbuf, rd_field(ioff), il_len, & 01032 MPI_REAL, mpi_comm, info) 01033 ELSE 01034 WRITE(nulprt,*)'Get - pb type incorrect ',ityp 01035 kinfo = CLIM_BadType 01036 GO TO 1010 01037 ENDIF 01038 ilgb = ilgb + il_len 01039 ENDDO 01040 IF (ilgb*ibyt .le. imaxbyt) THEN 01041 irecv = irecv + 1 01042 nbrecv = nbrecv + ilgb * ibyt 01043 #ifdef __VERBOSE 01044 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01045 'Get - <from:',imod, & 01046 '> <step:',kstep, & 01047 '> <len:',ilgb, & 01048 '> <type:',ibyt, & 01049 '> <tag:',itag,'>' 01050 CALL FLUSH(nulprt) 01051 #endif 01052 ELSE 01053 kinfo = CLIM_Unpack 01054 WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', & 01055 info,'>' 01056 ENDIF 01057 ELSE 01058 kinfo = CLIM_TimeOut 01059 WRITE(nulprt,FMT='(A,I3,A)') & 01060 'Get - abnormal exit from trecv <mpi ',info,'>' 01061 ENDIF 01062 ! 01063 #elif defined use_comm_GSIP 01064 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 01065 (0,'prism_get_proto', 'STOP -- only one reception from Oasis, myport(5,iport) should be 1') 01066 if (imod .ne. 0) CALL prism_abort_proto & 01067 (0,'prism_get_proto', 'STOP -- if received from Oasis, imod should be 0') 01068 if (itid .ne. 1) CALL prism_abort_proto & 01069 (0,'prism_get_proto', 'STOP -- if received from Oasis, itid should be 1') 01070 01071 ! 01072 ! Read info in channel from Oasis (no DIRECT communication) 01073 ! 01074 il_errgsip = mgi_read (ig_gsipr, pkworkps, ig_CLIMmax , 'R') 01075 IF (il_errgsip .GE. 0) THEN 01076 WRITE(UNIT = nulprt,FMT = *) & 01077 'prism_get_proto - pkworkps read OK:', il_errgsip 01078 ELSE 01079 WRITE(UNIT = nulprt,FMT = *) & 01080 '1- prism_get_proto - error :', il_errgsip 01081 CALL prism_abort_proto (0, 'prism_get_proto', & 01082 'STOP - pkworkps not read OK)') 01083 ENDIF 01084 ! 01085 ! Fill rd_field with segments of pkworkps 01086 ilgb = 0 01087 il_rst = 0 01088 il_ren = 0 01089 DO is=1,iseg 01090 ioff = mylink(4+2*is-1,ilk) + 1 01091 il_len = mylink(4+2*is,ilk) 01092 il_rst = il_ren + 1 01093 il_ren = il_rst + il_len - 1 01094 rd_field(ioff:ioff+il_len-1) = pkworkps(il_rst:il_ren) 01095 ! 01096 ilgb = ilgb + il_len 01097 ENDDO 01098 IF (ilgb .LE. ig_CLIMmax) THEN 01099 irecv = irecv + 1 01100 #ifdef __VERBOSE 01101 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01102 'Get - <from:',imod, '> <step:',kstep, & 01103 '> <len:',ilgb, '> <type:',ibyt, '> <tag:',itid,'>' 01104 CALL FLUSH(nulprt) 01105 #endif 01106 ELSE 01107 WRITE(UNIT = nulprt,FMT = *) & 01108 '2- prism_get_proto - error :', il_errgsip 01109 CALL prism_abort_proto (0, 'prism_get_proto', & 01110 'STOP - sum of segments greater than pkworkps size') 01111 ENDIF 01112 #endif 01113 ENDDO 01114 #ifdef balance 01115 CALL date_and_time(date,time,zone,values) 01116 millisec=values(8) 01117 sec_date=millisec/1000+values(7)+values(6)*60+& 01118 values(5)*3600+values(3)*86400 01119 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 01120 'Balance: ',cports(iport),'After MPI get ',sec_date 01121 #endif 01122 ! 01123 #ifdef __VERBOSE 01124 WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported' 01125 CALL FLUSH(nulprt) 01126 #endif 01127 ! 01128 #if !defined key_noIO 01129 ! 01130 !* If the user indicated in the namcouple that the field must be written 01131 !* to file, do the writing here : 01132 ! 01133 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 01134 ig_def_state(iport) .EQ. ip_ignout) THEN 01135 CALL psmile_write_4(iport,rd_field,kstep) 01136 ENDIF 01137 #endif 01138 ENDIF 01139 rd_field_2d(:,:) = RESHAPE (rd_field(:),(/size(rd_field_2d,1), & 01140 size(rd_field_2d,2)/)) 01141 ENDIF 01142 ENDIF 01143 ! 01144 ! ---------------------------------------------------------------- 01145 ! 01146 1010 CONTINUE 01147 ! 01148 #ifdef __VERBOSE 01149 WRITE(nulprt,*)'| | | Leaving routine prism_get_proto_r24' 01150 WRITE(nulprt,*) ' ' 01151 CALL FLUSH(nulprt) 01152 #endif 01153 ! 01154 RETURN 01155 END SUBROUTINE prism_get_proto_r24 01156 01157 SUBROUTINE prism_get_proto_r28(id_port_id,kstep,rd_field_2d,kinfo) 01158 ! 01159 !* *** PRISM_get *** PRISM 1.0 01160 ! 01161 ! purpose: 01162 ! -------- 01163 ! recv pfield from oasis or models connected to port id_port_id 01164 ! 01165 ! interface: 01166 ! ---------- 01167 ! id_port_id : port number of the field 01168 ! kstep : current time in seconds 01169 ! rd_field_2d : buffer of reals 01170 ! kinfo : output status 01171 ! 01172 ! lib mp: 01173 ! ------- 01174 ! mpi-1 or mpi-2 or gsip 01175 ! 01176 ! author: 01177 ! ------- 01178 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import) 01179 ! S. Legutke - MPI M&D (05/03 - kinfo = PRISM_Recvd added) 01180 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 01181 ! ---------------------------------------------------------------- 01182 USE mod_kinds_model 01183 USE mod_prism_proto 01184 USE mod_comprism_proto 01185 #if defined use_comm_GSIP 01186 USE mod_gsip_model 01187 #endif 01188 IMPLICIT none 01189 #if defined use_comm_MPI1 || defined use_comm_MPI2 01190 #include <mpif.h> 01191 INTEGER(kind=ip_intwp_p) istatus(MPI_STATUS_SIZE) 01192 #endif 01193 ! ---------------------------------------------------------------- 01194 INTEGER(kind=ip_intwp_p), intent(in) :: id_port_id, kstep 01195 INTEGER(kind=ip_intwp_p), intent(out) :: kinfo 01196 REAL(kind=ip_double_p), DIMENSION(:,:), intent(inout) :: rd_field_2d 01197 ! ---------------------------------------------------------------- 01198 REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field 01199 INTEGER(kind=ip_intwp_p) info, ip, iport 01200 INTEGER(kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb 01201 INTEGER(kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt 01202 INTEGER(kind=ip_intwp_p) iposbuf, imaxbyt 01203 #ifdef __DEBUG 01204 INTEGER(kind=ip_intwp_p) icount 01205 INTEGER(kind=ip_intwp_p), parameter :: icountmax=600 01206 LOGICAL :: iflag 01207 #endif 01208 #ifdef use_comm_GSIP 01209 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 01210 INTEGER :: mgi_read 01211 #endif 01212 #ifdef balance 01213 CHARACTER(8) :: date 01214 CHARACTER(10) :: time 01215 CHARACTER(5) :: zone 01216 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 01217 REAL(kind=ip_double_p):: millisec 01218 REAL(kind=ip_double_p):: sec_date 01219 #endif 01220 ! ---------------------------------------------------------------- 01221 ! 01222 #ifdef __VERBOSE 01223 WRITE(nulprt,*) ' ' 01224 WRITE(nulprt,*) '| | | Entering prism_get_proto_r28 for field ',id_port_id 01225 CALL FLUSH(nulprt) 01226 #endif 01227 01228 rd_field(:)=0 01229 #if defined use_comm_MPI1 || defined use_comm_MPI2 01230 istatus(:)=0 01231 #endif 01232 ! 01233 !* 0. Entering 01234 ! -------------- 01235 ! 01236 kinfo = PRISM_Ok 01237 ! 01238 !* 1. check for this port in my list 01239 ! --------------------------------- 01240 ! 01241 irecv = 0 01242 iport = -1 01243 ! 01244 ! Test if the field is defined in the namcouple and if its coupling period 01245 ! is not greater than the time of the simulation. 01246 IF (ig_def_freq(id_port_id) .eq. 0 .or. & 01247 ig_def_freq(id_port_id) .gt. ig_ntime .or. & 01248 ig_def_state(id_port_id) .eq. ip_auxilary) THEN 01249 GOTO 1010 01250 ENDIF 01251 IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id 01252 IF (iport.lt.0) THEN 01253 kinfo = CLIM_BadPort 01254 WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', & 01255 cports(id_port_id) 01256 GO TO 1010 01257 ENDIF 01258 ! 01259 !* Test if the current time is a coupling (or I/O) time 01260 ! 01261 IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN 01262 ! 01263 !* If the user indicated in the namcouple that the field is 01264 !* a field input-from-file (keyword 'INPUT' at the end of the 01265 !* field 1st line), do the reading from file here, e.g.: 01266 ! 01267 #if !defined key_noIO 01268 IF (ig_def_state(iport) .EQ. ip_input) THEN 01269 CALL psmile_read_8(iport,rd_field,kstep) 01270 kinfo = PRISM_Input 01271 ENDIF 01272 #endif 01273 ! 01274 !* Define return code (direct or via Oasis does not matter) 01275 ! 01276 IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN 01277 kinfo = PRISM_FromRest 01278 #if !defined key_noIO 01279 IF (ig_def_state(iport) .EQ. ip_ignout .OR. & 01280 ig_def_state(iport) .EQ. ip_expout) THEN 01281 kinfo = PRISM_FromRestOut 01282 ENDIF 01283 #endif 01284 ELSE 01285 IF (ig_def_state(iport) .NE. ip_input) THEN 01286 kinfo = PRISM_Recvd 01287 ! 01288 #if !defined key_noIO 01289 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 01290 ig_def_state(iport) .EQ. ip_ignout) THEN 01291 kinfo = PRISM_RecvOut 01292 ENDIF 01293 #endif 01294 ENDIF 01295 ENDIF 01296 ! 01297 !* Test if first import and if the user indicated in the 01298 !* namcouple that the field is 01299 !* exchanged directly between the models and not treated by 01300 !* Oasis (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line), 01301 !* do the reading from restart file (not implemented). 01302 ! 01303 IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. & 01304 (ig_def_state(iport) .eq. ip_ignored .or. & 01305 ig_def_state(iport) .eq. ip_ignout)) THEN 01306 ! 01307 !* Note: A model can have several restart files but same restart 01308 !* file can't be used by different models 01309 !* Test if model is serial or parallel and if variables are real 01310 ! or double precision 01311 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 01312 call read_filer8(rd_field, cports(iport),iport) 01313 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 01314 ELSE 01315 call read_file_parar8(rd_field, cports(iport),iport) 01316 #endif 01317 ENDIF 01318 #if !defined key_noIO 01319 IF (ig_def_state(iport) .EQ. ip_ignout) & 01320 CALL psmile_write_8(iport,rd_field,kstep) 01321 #endif 01322 ELSE 01323 !* 01324 !* If the user indicated in the namcouple that the field is 01325 !* a coupling field then do the import : 01326 IF (ig_def_state(iport) .NE. ip_output .AND. & 01327 ig_def_state(iport) .ne. ip_input) THEN 01328 ! 01329 !* Check for connected ports (in) 01330 ! ------------------------------ 01331 ! 01332 #ifdef __VERBOSE 01333 WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport) 01334 CALL FLUSH(nulprt) 01335 #endif 01336 ! 01337 ityp = myport(2,iport) 01338 ibyt = myport(3,iport) 01339 ! 01340 #ifdef balance 01341 CALL date_and_time(date,time,zone,values) 01342 millisec=values(8) 01343 sec_date=millisec/1000+values(7)+values(6)*60+& 01344 values(5)*3600+values(3)*86400 01345 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 01346 'Balance: ',cports(iport),'Before MPI get ',sec_date 01347 CALL FLUSH(nulprt) 01348 #endif 01349 DO ip=1,myport(5,iport) 01350 ! 01351 ilk = myport(5+ip,iport) 01352 imod = mylink(1,ilk) 01353 itid = mylink(2,ilk) 01354 itag = mylink(3,ilk) - kstep / ig_frqmin 01355 iseg = mylink(4,ilk) 01356 ! 01357 !* Implementation with "blocking" receives : the program will wait 01358 !* indefinitely until a message is received (this may generate a 01359 !* deadlock if all models are waiting on a receive). 01360 !* However this method will be more efficient in most cases than the 01361 !* receives with a time-out loop. 01362 ! 01363 #if defined use_comm_MPI1 || defined use_comm_MPI2 01364 #if defined __DEBUG 01365 ! 01366 !jl 01367 !jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox 01368 !jl exist in the network (2004-04-28) 01369 !jl 01370 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 01371 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 01372 ' comm = ',mpi_comm,' result is : ',iflag 01373 call flush(nulprt) 01374 01375 IF (.NOT.iflag) THEN 01376 icount = 0 01377 WAITLOOP: DO 01378 CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info ) 01379 icount = icount + 1 01380 IF ( iflag ) EXIT WAITLOOP 01381 IF ( icount .GE. icountmax ) THEN 01382 WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, & 01383 ' still negative after ',icountmax,' seconds : Abort the job' 01384 call flush(nulprt) 01385 CALL MPI_ABORT (mpi_comm, 0, mpi_err) 01386 ENDIF 01387 call sleep(1) 01388 END DO WAITLOOP 01389 WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount 01390 call flush(nulprt) 01391 ENDIF 01392 #endif 01393 !jl 01394 CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, & 01395 itid, itag, mpi_comm, istatus, info ) 01396 CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, & 01397 info ) 01398 ! 01399 IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN 01400 ilgb = 0 01401 iposbuf = 0 01402 DO is=1,iseg 01403 ioff = mylink(4+2*is-1,ilk) + 1 01404 il_len = mylink(4+2*is,ilk) 01405 ! 01406 IF ( ityp .EQ. PRISM_Real ) THEN 01407 CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, & 01408 iposbuf, rd_field(ioff), il_len, & 01409 MPI_DOUBLE_PRECISION, mpi_comm, info) 01410 ELSE 01411 WRITE(nulprt,*)'Get - pb type incorrect ',ityp 01412 kinfo = CLIM_BadType 01413 GO TO 1010 01414 ENDIF 01415 ilgb = ilgb + il_len 01416 ENDDO 01417 IF (ilgb*ibyt .le. imaxbyt) THEN 01418 irecv = irecv + 1 01419 nbrecv = nbrecv + ilgb * ibyt 01420 #ifdef __VERBOSE 01421 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01422 'Get - <from:',imod, & 01423 '> <step:',kstep, & 01424 '> <len:',ilgb, & 01425 '> <type:',ibyt, & 01426 '> <tag:',itag,'>' 01427 CALL FLUSH(nulprt) 01428 #endif 01429 ELSE 01430 kinfo = CLIM_Unpack 01431 WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', & 01432 info,'>' 01433 GO TO 1010 01434 ENDIF 01435 ELSE 01436 kinfo = CLIM_TimeOut 01437 WRITE(nulprt,FMT='(A,I3,A)') & 01438 'Get - abnormal exit from trecv <mpi ',info,'>' 01439 GO TO 1010 01440 ENDIF 01441 ! 01442 #elif defined use_comm_GSIP 01443 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 01444 (0,'prism_get_proto', 'STOP -- only one reception from Oasis, myport(5,iport) should be 1') 01445 if (imod .ne. 0) CALL prism_abort_proto & 01446 (0,'prism_get_proto', 'STOP -- if received from Oasis, imod should be 0') 01447 if (itid .ne. 1) CALL prism_abort_proto & 01448 (0,'prism_get_proto', 'STOP -- if received from Oasis, itid should be 1') 01449 01450 ! 01451 ! Read info in channel from Oasis (no DIRECT communication) 01452 ! 01453 il_errgsip = mgi_read (ig_gsipr, pkworkps, ig_CLIMmax , 'D') 01454 IF (il_errgsip .GE. 0) THEN 01455 WRITE(UNIT = nulprt,FMT = *) & 01456 'prism_get_proto - pkworkps read OK:', il_errgsip 01457 ELSE 01458 WRITE(UNIT = nulprt,FMT = *) & 01459 '1- prism_get_proto - error :', il_errgsip 01460 CALL prism_abort_proto (0, 'prism_get_proto', & 01461 'STOP - pkworkps not read OK)') 01462 ENDIF 01463 ! 01464 ! Fill rd_field with segments of pkworkps 01465 ilgb = 0 01466 il_rst = 0 01467 il_ren = 0 01468 DO is=1,iseg 01469 ioff = mylink(4+2*is-1,ilk) + 1 01470 il_len = mylink(4+2*is,ilk) 01471 il_rst = il_ren + 1 01472 il_ren = il_rst + il_len - 1 01473 rd_field(ioff:ioff+il_len-1) = pkworkps(il_rst:il_ren) 01474 ! 01475 ilgb = ilgb + il_len 01476 ENDDO 01477 IF (ilgb .LE. ig_CLIMmax) THEN 01478 irecv = irecv + 1 01479 #ifdef __VERBOSE 01480 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01481 'Get - <from:',imod, '> <step:',kstep, & 01482 '> <len:',ilgb, '> <type:',ibyt, '> <tag:',itid,'>' 01483 CALL FLUSH(nulprt) 01484 #endif 01485 ELSE 01486 WRITE(UNIT = nulprt,FMT = *) & 01487 '2- prism_get_proto - error :', il_errgsip 01488 CALL prism_abort_proto (0, 'prism_get_proto', & 01489 'STOP - sum of segments greater than pkworkps size') 01490 ENDIF 01491 #endif 01492 ENDDO 01493 #ifdef balance 01494 CALL date_and_time(date,time,zone,values) 01495 millisec=values(8) 01496 sec_date=millisec/1000+values(7)+values(6)*60+& 01497 values(5)*3600+values(3)*86400 01498 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 01499 'Balance: ',cports(iport),'After MPI get ',sec_date 01500 #endif 01501 ! 01502 #ifdef __VERBOSE 01503 WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported' 01504 CALL FLUSH(nulprt) 01505 #endif 01506 ! 01507 #if !defined key_noIO 01508 ! 01509 !* If the user indicated in the namcouple that the field must be written 01510 !* to file, do the writing here : 01511 ! 01512 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 01513 ig_def_state(iport) .EQ. ip_ignout) THEN 01514 CALL psmile_write_8(iport,rd_field,kstep) 01515 ENDIF 01516 #endif 01517 ENDIF 01518 rd_field_2d(:,:) = RESHAPE (rd_field(:),(/size(rd_field_2d,1), & 01519 size(rd_field_2d,2)/)) 01520 ENDIF 01521 ENDIF 01522 ! 01523 ! ---------------------------------------------------------------- 01524 ! 01525 1010 CONTINUE 01526 ! 01527 #ifdef __VERBOSE 01528 WRITE(nulprt,*)'| | | Leaving routine prism_get_proto_r28' 01529 WRITE(nulprt,*) ' ' 01530 CALL FLUSH(nulprt) 01531 #endif 01532 ! 01533 RETURN 01534 END SUBROUTINE prism_get_proto_r28 01535 01536 ! ******************************************************************** 01537 ! ******************************************************************** 01538 ! ******************************************************************** 01539 ! 01540 !* *** READ_FILE *** PRISM 1.0 01541 ! 01542 ! purpose: 01543 ! -------- 01544 ! At first time step, reads input fields from binary files or 01545 ! netcdf files. 01546 ! 01547 ! interface: 01548 ! ---------- 01549 ! inp_fld : field to be read from the restart file 01550 ! cd_port : symbolic name of the field 01551 ! id_port : port number of the field 01552 ! 01553 ! lib mp: 01554 ! ------- 01555 ! mpi-1 01556 ! 01557 ! author: 01558 ! ------- 01559 ! Eric Sevault - METEO FRANCE 01560 ! Laurent Terray - CERFACS 01561 ! Jean Latour - F.S.E. (mpi-2) 01562 ! Arnaud Caubel - Adaptation to PRISM interface 01563 ! ---------------------------------------------------------------- 01564 SUBROUTINE read_filer4(inp_fld, cd_port,id_port) 01565 ! ---------------------------------------------------------------- 01566 USE mod_kinds_model 01567 USE mod_prism_proto 01568 USE mod_comprism_proto 01569 IMPLICIT NONE 01570 #ifdef use_netCDF 01571 #include <netcdf.inc> 01572 #endif 01573 ! ---------------------------------------------------------------- 01574 INTEGER(kind=ip_intwp_p) :: id_port 01575 REAL(kind=ip_single_p) :: inp_fld(myport(4,id_port)) 01576 CHARACTER(len=8) :: cd_port 01577 ! ---------------------------------------------------------------- 01578 INTEGER(kind=ip_intwp_p) il_unit 01579 INTEGER(kind=ip_intwp_p) ierror,info, il_varid, il_ncid, istatus 01580 LOGICAL ll_file 01581 ! ---------------------------------------------------------------- 01582 ! 01583 #ifdef __VERBOSE 01584 WRITE(nulprt,*) ' ' 01585 WRITE(nulprt,*)'| | | Entering routine read_filer4' 01586 CALL FLUSH(nulprt) 01587 #endif 01588 ! 01589 !* Test if restart file is in NETCDF format or not 01590 ! 01591 #ifdef use_netCDF 01592 IF (lg_ncdfrst) THEN 01593 ! 01594 !* Case NETCDF format 01595 ! 01596 istatus = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE,il_ncid) 01597 IF (istatus.ne.NF_NOERR) THEN 01598 WRITE(nulprt,*) NF_STRERROR(istatus) 01599 WRITE(nulprt,*)' stop in PRISM_get routine read_filer4 ' 01600 STOP 01601 ENDIF 01602 istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid) 01603 IF (istatus.ne.NF_NOERR) THEN 01604 WRITE(nulprt,*) NF_STRERROR(istatus) 01605 WRITE(nulprt,*)' stop in PRISM_get routine read_filer4 ' 01606 STOP 01607 ENDIF 01608 istatus = NF_GET_VAR_REAL (il_ncid, il_varid, inp_fld) 01609 IF (istatus.ne.NF_NOERR) THEN 01610 WRITE(nulprt,*) NF_STRERROR(istatus) 01611 WRITE(nulprt,*)' stop in PRISM_get routine read_filer4 ' 01612 STOP 01613 ENDIF 01614 istatus = NF_CLOSE(il_ncid) 01615 IF (istatus.ne.NF_NOERR) THEN 01616 WRITE(nulprt,*) NF_STRERROR(istatus) 01617 WRITE(nulprt,*)' stop in PRISM_get routine read_filer4 ' 01618 STOP 01619 ENDIF 01620 ELSE 01621 #endif 01622 ! 01623 !* Case binary format 01624 ! 01625 il_unit = nulprt + 1 01626 INQUIRE (il_unit,OPENED = ll_file) 01627 DO WHILE (ll_file) 01628 il_unit = il_unit + 1 01629 INQUIRE (il_unit,OPENED = ll_file) 01630 END DO 01631 OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED') 01632 CALL locreadr4(cd_port,inp_fld,myport(4,id_port),il_unit, & 01633 ierror, nulprt) 01634 CLOSE (il_unit) 01635 #ifdef use_netCDF 01636 ENDIF 01637 #endif 01638 ! 01639 #ifdef __VERBOSE 01640 WRITE(nulprt,*)'| | | Leaving routine read_filer4' 01641 WRITE(nulprt,*) ' ' 01642 CALL FLUSH(nulprt) 01643 #endif 01644 ! 01645 END SUBROUTINE read_filer4 01646 01647 ! ******************************************************************** 01648 ! ******************************************************************** 01649 ! ******************************************************************** 01650 ! 01651 !* *** READ_FILE *** PRISM 1.0 01652 ! 01653 ! purpose: 01654 ! -------- 01655 ! At first time step, reads input fields from binary files or 01656 ! netcdf files. 01657 ! 01658 ! interface: 01659 ! ---------- 01660 ! inp_fld : field to be read from the restart file 01661 ! cd_port : symbolic name of the field 01662 ! id_port : port number of the field 01663 ! 01664 ! lib mp: 01665 ! ------- 01666 ! mpi-1 01667 ! 01668 ! author: 01669 ! ------- 01670 ! Eric Sevault - METEO FRANCE 01671 ! Laurent Terray - CERFACS 01672 ! Jean Latour - F.S.E. (mpi-2) 01673 ! Arnaud Caubel - Adaptation to PRISM interface 01674 ! ---------------------------------------------------------------- 01675 SUBROUTINE read_filer8(inp_fld, cd_port,id_port) 01676 ! ---------------------------------------------------------------- 01677 USE mod_kinds_model 01678 USE mod_prism_proto 01679 USE mod_comprism_proto 01680 IMPLICIT NONE 01681 #ifdef use_netCDF 01682 #include <netcdf.inc> 01683 #endif 01684 ! ---------------------------------------------------------------- 01685 INTEGER (kind=ip_intwp_p) :: id_port 01686 REAL(kind=ip_double_p) :: inp_fld(myport(4,id_port)) 01687 CHARACTER(len=8) :: cd_port 01688 ! ---------------------------------------------------------------- 01689 INTEGER (kind=ip_intwp_p) il_unit 01690 INTEGER (kind=ip_intwp_p) ierror,info, il_varid, il_ncid, istatus 01691 LOGICAL ll_file 01692 ! ---------------------------------------------------------------- 01693 ! 01694 #ifdef __VERBOSE 01695 WRITE(nulprt,*) ' ' 01696 WRITE(nulprt,*)'| | | Entering routine read_filer8' 01697 CALL FLUSH(nulprt) 01698 #endif 01699 ! 01700 !* Test if restart file is in NETCDF format or not 01701 ! 01702 #ifdef use_netCDF 01703 IF (lg_ncdfrst) THEN 01704 ! 01705 !* Case NETCDF format 01706 ! 01707 istatus = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE,il_ncid) 01708 IF (istatus.ne.NF_NOERR) THEN 01709 WRITE(nulprt,*) NF_STRERROR(istatus) 01710 WRITE(nulprt,*)' stop in PRISM_get routine read_filer8 ' 01711 STOP 01712 ENDIF 01713 istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid) 01714 IF (istatus.ne.NF_NOERR) THEN 01715 WRITE(nulprt,*) NF_STRERROR(istatus) 01716 WRITE(nulprt,*)' stop in PRISM_get routine read_filer8 ' 01717 STOP 01718 ENDIF 01719 istatus = NF_GET_VAR_DOUBLE (il_ncid, il_varid, inp_fld) 01720 IF (istatus.ne.NF_NOERR) THEN 01721 WRITE(nulprt,*) NF_STRERROR(istatus) 01722 WRITE(nulprt,*)' stop in PRISM_get routine read_filer8 ' 01723 STOP 01724 ENDIF 01725 istatus = NF_CLOSE(il_ncid) 01726 IF (istatus.ne.NF_NOERR) THEN 01727 WRITE(nulprt,*) NF_STRERROR(istatus) 01728 WRITE(nulprt,*)' stop in PRISM_get routine read_filer8 ' 01729 STOP 01730 ENDIF 01731 ELSE 01732 #endif 01733 ! 01734 !* Case binary format 01735 ! 01736 il_unit = nulprt + 1 01737 INQUIRE (il_unit,OPENED = ll_file) 01738 DO WHILE (ll_file) 01739 il_unit = il_unit + 1 01740 INQUIRE (il_unit,OPENED = ll_file) 01741 END DO 01742 OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED') 01743 CALL locreadr8(cd_port,inp_fld,myport(4,id_port),il_unit, & 01744 ierror, nulprt) 01745 CLOSE (il_unit) 01746 #ifdef use_netCDF 01747 ENDIF 01748 #endif 01749 ! 01750 #ifdef __VERBOSE 01751 WRITE(nulprt,*)'| | | Leaving routine read_filer8' 01752 WRITE(nulprt,*) ' ' 01753 CALL FLUSH(nulprt) 01754 #endif 01755 ! 01756 END SUBROUTINE read_filer8 01757 01758 ! ******************************************************************** 01759 ! ******************************************************************** 01760 ! ******************************************************************** 01761 ! 01762 !* *** READ_FILE_PARA *** PRISM 1.0 01763 ! 01764 ! purpose: 01765 ! -------- 01766 ! At first time step, reads input fields from binary files or 01767 ! netcdf files. 01768 ! 01769 ! interface: 01770 ! ---------- 01771 ! inp_fld : field to be read from the restart file 01772 ! cd_port : symbolic name of the field 01773 ! id_port : port number of the field 01774 ! 01775 ! lib mp: 01776 ! ------- 01777 ! mpi-1 01778 ! 01779 ! author: 01780 ! ------- 01781 ! Eric Sevault - METEO FRANCE 01782 ! Laurent Terray - CERFACS 01783 ! Jean Latour - F.S.E. (mpi-2) 01784 ! Arnaud Caubel - Adaptation to PRISM interface 01785 ! ---------------------------------------------------------------- 01786 SUBROUTINE read_file_parar4(inp_fld, cd_port, id_port) 01787 ! ---------------------------------------------------------------- 01788 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 01789 USE mod_kinds_model 01790 USE mod_prism_proto 01791 USE mod_comprism_proto 01792 IMPLICIT NONE 01793 #ifdef use_netCDF 01794 #include <netcdf.inc> 01795 #endif 01796 #include <mpif.h> 01797 INTEGER (kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus 01798 ! ---------------------------------------------------------------- 01799 INTEGER (kind=ip_intwp_p) :: id_port 01800 CHARACTER(len=8) :: cd_port 01801 REAL(kind=ip_single_p) :: inp_fld(myport(4,id_port)) 01802 ! ---------------------------------------------------------------- 01803 INTEGER (kind=ip_intwp_p),PARAMETER :: ip_tag=100 01804 INTEGER (kind=ip_intwp_p) il_unit 01805 INTEGER (kind=ip_intwp_p) ierror, info, il_varid, il_ncid, il_status_ncdf, il_aux 01806 INTEGER (kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_aux, iposbuf, il_off, il_len 01807 INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast 01808 REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_start, rl_work 01809 REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast 01810 LOGICAL ll_file 01811 INTEGER(kind=ip_intwp_p)::il_sndreq 01812 ! ---------------------------------------------------------------- 01813 ! 01814 #ifdef __VERBOSE 01815 WRITE(nulprt,*) ' ' 01816 WRITE(nulprt,*)'| | | Entering routine read_file_parar4' 01817 CALL FLUSH(nulprt) 01818 #endif 01819 ! 01820 istatus(:)=0 01821 ! 01822 !* Each process of local communicator sends his decomposition to master proc 01823 ! 01824 IF (mpi_rank.NE.0) THEN 01825 CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, & 01826 ip_tag, ig_local_comm, ierror ) 01827 CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, & 01828 ip_tag+1, ig_local_comm, ierror ) 01829 ENDIF 01830 ! 01831 !* Master proc receives each process decomposition 01832 ! 01833 IF (mpi_rank.eq.0) THEN 01834 il_maxgrd = 0 01835 ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod))) 01836 il_paral_mast(:,:)=0 01837 il_paral_mast(:,1)=mydist(:,id_port) 01838 il_aux = myport(4,id_port) 01839 il_maxgrd = il_maxgrd + il_aux 01840 DO ib = 1, kbcplproc(ig_mynummod)-1 01841 CALL MPI_Recv (il_paral_mast(:,ib+1), & 01842 CLIM_Parsize, MPI_INTEGER, ib, & 01843 ip_tag, ig_local_comm, istatus, ierror ) 01844 CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, & 01845 ip_tag+1, ig_local_comm, istatus, ierror ) 01846 il_maxgrd = il_maxgrd + il_aux 01847 END DO 01848 il_maxbyte = il_maxgrd * 4 01849 ENDIF 01850 ALLOCATE(rl_work(myport(4,id_port))) 01851 IF (mpi_rank.eq.0) THEN 01852 ALLOCATE (rl_start(il_maxgrd)) 01853 ALLOCATE(rl_work_mast(il_maxgrd)) 01854 rl_start(:)=0 01855 rl_work_mast(:)=0 01856 ! 01857 !* Test if restart file is in NETCDF format or not 01858 ! 01859 #ifdef use_netCDF 01860 IF (lg_ncdfrst) THEN 01861 ! 01862 !* Case NETCDF format 01863 ! 01864 il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE, & 01865 il_ncid) 01866 IF (il_status_ncdf.ne.NF_NOERR) THEN 01867 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 01868 WRITE(nulprt,*)' stop in PRISM_get routine read_file_parar4 ' 01869 STOP 01870 ENDIF 01871 il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid) 01872 IF (il_status_ncdf.ne.NF_NOERR) THEN 01873 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 01874 WRITE(nulprt,*)' stop in PRISM_get routine read_file_parar4 ' 01875 STOP 01876 ENDIF 01877 il_status_ncdf = NF_GET_VAR_REAL (il_ncid, il_varid, rl_start) 01878 IF (il_status_ncdf.ne.NF_NOERR) THEN 01879 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 01880 WRITE(nulprt,*)' stop in PRISM_get routine read_file_parar4 ' 01881 STOP 01882 ENDIF 01883 il_status_ncdf = NF_CLOSE(il_ncid) 01884 IF (il_status_ncdf.ne.NF_NOERR) THEN 01885 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 01886 WRITE(nulprt,*)' stop in PRISM_get routine read_file_parar4 ' 01887 STOP 01888 ENDIF 01889 ELSE 01890 #endif 01891 ! 01892 !* Case binary format 01893 ! 01894 il_unit = nulprt + 1 01895 INQUIRE (il_unit,OPENED = ll_file) 01896 DO WHILE (ll_file) 01897 il_unit = il_unit + 1 01898 INQUIRE (il_unit,OPENED = ll_file) 01899 END DO 01900 OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED') 01901 CALL locreadr4(cd_port,rl_start,il_maxgrd,il_unit, & 01902 ierror, nulprt) 01903 ! 01904 CLOSE (il_unit) 01905 #ifdef use_netCDF 01906 ENDIF 01907 #endif 01908 ! 01909 !* Master proc sends to each proc his part of the field 01910 ! 01911 DO ib = kbcplproc(ig_mynummod)- 1,0,-1 01912 iposbuf=0 01913 DO ib_aux=1,il_paral_mast(clim_segments,ib+1) 01914 il_off=il_paral_mast(clim_segments+2*ib_aux-1,ib+1)+1 01915 il_len=il_paral_mast(clim_segments+2*ib_aux,ib+1) 01916 call MPI_Pack(rl_start(il_off:il_off+il_len-1), & 01917 il_len,MPI_REAL,rl_work_mast,il_maxbyte, & 01918 iposbuf, ig_local_comm, ierror) 01919 END DO 01920 IF(ib.GT.0) THEN 01921 CALL MPI_Send ( rl_work_mast, iposbuf, MPI_PACKED, ib, & 01922 ip_tag+2, ig_local_comm, ierror ) 01923 ELSE 01924 CALL MPI_ISend ( rl_work_mast, iposbuf, MPI_PACKED, ib, & 01925 ip_tag+2, ig_local_comm,il_sndreq, ierror ) 01926 ENDIF 01927 ENDDO 01928 DEALLOCATE (il_paral_mast) 01929 DEALLOCATE (rl_work_mast) 01930 DEALLOCATE (rl_start) 01931 ENDIF 01932 ! 01933 !* Each proc receives his part of the field 01934 ! 01935 call MPI_Recv ( rl_work, myport(4,id_port)*4, MPI_PACKED, 0, & 01936 ip_tag+2, ig_local_comm, istatus, ierror ) 01937 iposbuf=0 01938 il_off=1 01939 il_len=myport(4,id_port) 01940 CALL MPI_Unpack(rl_work, myport(4,id_port)*4,iposbuf, & 01941 inp_fld(il_off:il_off+il_len-1), & 01942 il_len, MPI_REAL, ig_local_comm, ierror) 01943 IF (mpi_rank.eq.0) THEN 01944 call MPI_Wait(il_sndreq,istatus,ierror) 01945 ENDIF 01946 DEALLOCATE(rl_work) 01947 ! 01948 #ifdef __VERBOSE 01949 WRITE(nulprt,*)'| | | Leaving routine read_file_parar4' 01950 WRITE(nulprt,*) ' ' 01951 CALL FLUSH(nulprt) 01952 #endif 01953 ! 01954 #endif 01955 ! 01956 END SUBROUTINE read_file_parar4 01957 01958 ! ******************************************************************** 01959 ! ******************************************************************** 01960 ! ******************************************************************** 01961 ! 01962 !* *** READ_FILE_PARA *** PRISM 1.0 01963 ! 01964 ! purpose: 01965 ! -------- 01966 ! At first time step, reads input fields from binary files or 01967 ! netcdf files. 01968 ! 01969 ! interface: 01970 ! ---------- 01971 ! inp_fld : field to be read from the restart file 01972 ! cd_port : symbolic name of the field 01973 ! id_port : port number of the field 01974 ! 01975 ! lib mp: 01976 ! ------- 01977 ! mpi-1 01978 ! 01979 ! author: 01980 ! ------- 01981 ! Eric Sevault - METEO FRANCE 01982 ! Laurent Terray - CERFACS 01983 ! Jean Latour - F.S.E. (mpi-2) 01984 ! Arnaud Caubel - Adaptation to PRISM interface 01985 ! ---------------------------------------------------------------- 01986 SUBROUTINE read_file_parar8(inp_fld, cd_port, id_port) 01987 ! ---------------------------------------------------------------- 01988 #if defined use_libMPI || defined use_comm_MPI1 || defined use_comm_MPI2 01989 USE mod_kinds_model 01990 USE mod_prism_proto 01991 USE mod_comprism_proto 01992 IMPLICIT NONE 01993 #ifdef use_netCDF 01994 #include <netcdf.inc> 01995 #endif 01996 #include <mpif.h> 01997 INTEGER(kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus 01998 ! ---------------------------------------------------------------- 01999 CHARACTER(len=8) :: cd_port 02000 INTEGER(kind=ip_intwp_p) :: id_port 02001 REAL(kind=ip_double_p) :: inp_fld(myport(4,id_port)) 02002 ! ---------------------------------------------------------------- 02003 INTEGER(kind=ip_intwp_p),PARAMETER :: ip_tag=100 02004 INTEGER(kind=ip_intwp_p) il_unit, il_aux 02005 INTEGER(kind=ip_intwp_p) ierror, info, il_varid, il_ncid, il_status_ncdf 02006 INTEGER(kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_aux, iposbuf, il_off, il_len 02007 INTEGER(kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast 02008 REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_start, rl_work 02009 REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast 02010 LOGICAL ll_file 02011 INTEGER(kind=ip_intwp_p)::il_sndreq 02012 ! ---------------------------------------------------------------- 02013 ! 02014 #ifdef __VERBOSE 02015 WRITE(nulprt,*) ' ' 02016 WRITE(nulprt,*)'| | | Entering routine read_file_parar4' 02017 CALL FLUSH(nulprt) 02018 #endif 02019 ! 02020 istatus(:)=0 02021 ! 02022 !* Each process of local communicator sends his decomposition to master proc 02023 ! 02024 IF (mpi_rank.ne.0) THEN 02025 CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, & 02026 ip_tag, ig_local_comm, ierror ) 02027 CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, & 02028 ip_tag+1, ig_local_comm, ierror ) 02029 ENDIF 02030 ! 02031 !* Master proc receives each process decomposition 02032 ! 02033 IF (mpi_rank.eq.0) THEN 02034 il_maxgrd = 0 02035 ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod))) 02036 il_paral_mast(:,:)=0 02037 il_paral_mast(:,1)=mydist(:,id_port) 02038 il_aux = myport(4,id_port) 02039 il_maxgrd = il_maxgrd + il_aux 02040 DO ib = 1, kbcplproc(ig_mynummod)-1 02041 CALL MPI_Recv (il_paral_mast(:,ib+1), & 02042 CLIM_Parsize, MPI_INTEGER, ib, & 02043 ip_tag, ig_local_comm, istatus, ierror ) 02044 CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, & 02045 ip_tag+1, ig_local_comm, istatus, ierror ) 02046 il_maxgrd = il_maxgrd + il_aux 02047 END DO 02048 il_maxbyte = il_maxgrd * 8 02049 ENDIF 02050 ALLOCATE(rl_work(myport(4,id_port))) 02051 rl_work(:)=0 02052 IF (mpi_rank.eq.0) THEN 02053 ALLOCATE (rl_start(il_maxgrd)) 02054 ALLOCATE(rl_work_mast(il_maxgrd)) 02055 rl_start(:)=0 02056 rl_work_mast(:)=0 02057 ! 02058 !* Test if restart file is in NETCDF format or not 02059 ! 02060 #ifdef use_netCDF 02061 IF (lg_ncdfrst) THEN 02062 ! 02063 !* Case NETCDF format 02064 ! 02065 il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE, & 02066 il_ncid) 02067 IF (il_status_ncdf.ne.NF_NOERR) THEN 02068 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 02069 WRITE(nulprt,*)' stop in PRISM_get routine read_file_parar8 ' 02070 STOP 02071 ENDIF 02072 il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid) 02073 IF (il_status_ncdf.ne.NF_NOERR) THEN 02074 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 02075 WRITE(nulprt,*)' stop in PRISM_get routine read_file_parar8 ' 02076 STOP 02077 ENDIF 02078 il_status_ncdf = NF_GET_VAR_DOUBLE (il_ncid, il_varid, rl_start) 02079 IF (il_status_ncdf.ne.NF_NOERR) THEN 02080 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 02081 WRITE(nulprt,*)' stop in PRISM_put routine read_file_parar8 ' 02082 STOP 02083 ENDIF 02084 il_status_ncdf = NF_CLOSE(il_ncid) 02085 IF (il_status_ncdf.ne.NF_NOERR) THEN 02086 WRITE(nulprt,*) NF_STRERROR(il_status_ncdf) 02087 WRITE(nulprt,*)' stop in PRISM_get routine read_file_parar8 ' 02088 STOP 02089 ENDIF 02090 ELSE 02091 #endif 02092 ! 02093 !* Case binary format 02094 ! 02095 il_unit = nulprt + 1 02096 INQUIRE (il_unit,OPENED = ll_file) 02097 DO WHILE (ll_file) 02098 il_unit = il_unit + 1 02099 INQUIRE (il_unit,OPENED = ll_file) 02100 END DO 02101 OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED') 02102 CALL locreadr8(cd_port,rl_start,il_maxgrd,il_unit, & 02103 ierror, nulprt) 02104 ! 02105 CLOSE (il_unit) 02106 #ifdef use_netCDF 02107 ENDIF 02108 #endif 02109 ! 02110 !* Master proc sends to each proc his part of the field 02111 ! 02112 DO ib = kbcplproc(ig_mynummod)- 1,0,-1 02113 iposbuf=0 02114 DO ib_aux=1,il_paral_mast(clim_segments,ib+1) 02115 il_off=il_paral_mast(clim_segments+2*ib_aux-1,ib+1)+1 02116 il_len=il_paral_mast(clim_segments+2*ib_aux,ib+1) 02117 call MPI_Pack(rl_start(il_off:il_off+il_len-1), & 02118 il_len,MPI_DOUBLE_PRECISION,rl_work_mast,il_maxbyte, & 02119 iposbuf, ig_local_comm, ierror) 02120 END DO 02121 IF(ib.GT.0) THEN 02122 CALL MPI_Send ( rl_work_mast, iposbuf, MPI_PACKED, ib, & 02123 ip_tag+2, ig_local_comm, ierror ) 02124 ELSE 02125 CALL MPI_ISend ( rl_work_mast, iposbuf, MPI_PACKED, ib, & 02126 ip_tag+2, ig_local_comm,il_sndreq, ierror ) 02127 ENDIF 02128 ENDDO 02129 DEALLOCATE (il_paral_mast) 02130 DEALLOCATE (rl_work_mast) 02131 DEALLOCATE (rl_start) 02132 ENDIF 02133 ! 02134 !* Each proc receives his part of the field 02135 ! 02136 call MPI_Recv ( rl_work, myport(4,id_port)*8, MPI_PACKED, 0, & 02137 ip_tag+2, ig_local_comm, istatus, ierror ) 02138 iposbuf=0 02139 il_off=1 02140 il_len=myport(4,id_port) 02141 CALL MPI_Unpack(rl_work, myport(4,id_port)*8,iposbuf, & 02142 inp_fld(il_off:il_off+il_len-1), & 02143 il_len, MPI_DOUBLE_PRECISION, ig_local_comm, ierror) 02144 IF (mpi_rank.eq.0) THEN 02145 call MPI_Wait(il_sndreq,istatus,ierror) 02146 ENDIF 02147 DEALLOCATE(rl_work) 02148 ! 02149 #ifdef __VERBOSE 02150 WRITE(nulprt,*)'| | | Leaving routine read_file_parar8' 02151 WRITE(nulprt,*) ' ' 02152 CALL FLUSH(nulprt) 02153 #endif 02154 ! 02155 #endif 02156 END SUBROUTINE read_file_parar8 02157 02158 ! 02159 ! ******************************************************************** 02160 ! ******************************************************************** 02161 ! ******************************************************************** 02162 ! 02163 SUBROUTINE locreadr4 ( cdfldn, pfield, kdimax, knulre, kflgre, kout) 02164 ! 02165 !**** *locread* - Read binary field on unit knulre 02166 ! 02167 ! Purpose: 02168 ! ------- 02169 ! Find string cdfldn on unit knulre and read array pfield 02170 ! 02171 !** Interface: 02172 ! --------- 02173 ! *CALL* *locread (cdfldn, pfield, kdimax, knulre, kflgre, kout)* 02174 ! 02175 ! Input: 02176 ! ----- 02177 ! cdfldn : character string locator 02178 ! kdimax : dimension of field to be read 02179 ! knulre : logical unit to be read 02180 ! kout : logical unit to write messages 02181 ! 02182 ! Output: 02183 ! ------ 02184 ! pfield : field array (real 1D) 02185 ! kflgre : error status flag 02186 ! 02187 ! Reference: 02188 ! --------- 02189 ! See OASIS manual (1995) 02190 ! 02191 ! History: 02192 ! ------- 02193 ! Version Programmer Date Description 02194 ! ------- ---------- ---- ----------- 02195 ! 2.0 L. Terray 95/09/01 created 02196 ! 02197 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02198 ! 02199 ! 02200 !* ---------------------------- Argument declarations ------------------- 02201 ! 02202 USE mod_comprism_proto 02203 INTEGER (kind=ip_intwp_p) kdimax, knulre, kflgre, kout 02204 REAL(kind=ip_single_p) :: pfield(kdimax) 02205 CHARACTER*8 cdfldn 02206 ! 02207 !* ---------------------------- Local declarations ---------------------- 02208 ! 02209 CHARACTER*8 clecfl 02210 ! 02211 !* ---------------------------- Poema verses ---------------------------- 02212 ! 02213 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02214 ! 02215 ! 02216 #ifdef __VERBOSE 02217 WRITE(nulprt,*)' ' 02218 WRITE(nulprt,*)'| | | Entering routine locreadr4' 02219 CALL FLUSH(nulprt) 02220 #endif 02221 ! 02222 !* 1. Initialization 02223 ! -------------- 02224 ! 02225 WRITE (UNIT = kout,FMT = 1001) knulre 02226 ! 02227 !* Formats 02228 ! 02229 1001 FORMAT('Locread : Read binary file connected to unit = ',I4) 02230 ! 02231 ! 2. Find field in file 02232 ! ------------------ 02233 ! 02234 REWIND knulre 02235 200 CONTINUE 02236 !* Find string 02237 READ (UNIT = knulre, ERR = 200, END = 210) clecfl 02238 IF (clecfl .NE. cdfldn) GO TO 200 02239 !* Read associated field 02240 READ (UNIT = knulre, ERR = 210, END = 210) pfield 02241 !* Reading done and ok 02242 kflgre = 0 02243 GO TO 220 02244 !* Problem in reading 02245 210 kflgre = 1 02246 220 CONTINUE 02247 ! 02248 ! 02249 !* 3. End of routine 02250 ! -------------- 02251 ! 02252 ! 02253 #ifdef __VERBOSE 02254 WRITE(nulprt,*)'| | | Leaving routine locreadr4' 02255 WRITE(nulprt,*)' ' 02256 CALL FLUSH(nulprt) 02257 #endif 02258 ! 02259 RETURN 02260 END SUBROUTINE locreadr4 02261 02262 ! 02263 ! ******************************************************************** 02264 ! ******************************************************************** 02265 ! ******************************************************************** 02266 ! 02267 SUBROUTINE locreadr8 ( cdfldn, pfield, kdimax, knulre, kflgre, kout) 02268 ! 02269 !**** *locread* - Read binary field on unit knulre 02270 ! 02271 ! Purpose: 02272 ! ------- 02273 ! Find string cdfldn on unit knulre and read array pfield 02274 ! 02275 !** Interface: 02276 ! --------- 02277 ! *CALL* *locread (cdfldn, pfield, kdimax, knulre, kflgre, kout)* 02278 ! 02279 ! Input: 02280 ! ----- 02281 ! cdfldn : character string locator 02282 ! kdimax : dimension of field to be read 02283 ! knulre : logical unit to be read 02284 ! kout : logical unit to write messages 02285 ! 02286 ! Output: 02287 ! ------ 02288 ! pfield : field array (real 1D) 02289 ! kflgre : error status flag 02290 ! 02291 ! Reference: 02292 ! --------- 02293 ! See OASIS manual (1995) 02294 ! 02295 ! History: 02296 ! ------- 02297 ! Version Programmer Date Description 02298 ! ------- ---------- ---- ----------- 02299 ! 2.0 L. Terray 95/09/01 created 02300 ! 02301 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02302 ! 02303 ! 02304 !* ---------------------------- Argument declarations ------------------- 02305 ! 02306 USE mod_comprism_proto 02307 INTEGER(kind=ip_intwp_p) kdimax, knulre, kflgre, kout 02308 REAL(kind=ip_double_p) :: pfield(kdimax) 02309 CHARACTER*8 cdfldn 02310 ! 02311 !* ---------------------------- Local declarations ---------------------- 02312 ! 02313 CHARACTER*8 clecfl 02314 ! 02315 !* ---------------------------- Poema verses ---------------------------- 02316 ! 02317 ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 02318 ! 02319 ! 02320 #ifdef __VERBOSE 02321 WRITE(nulprt,*)' ' 02322 WRITE(nulprt,*)'| | | Entering routine locreadr8' 02323 CALL FLUSH(nulprt) 02324 #endif 02325 ! 02326 !* 1. Initialization 02327 ! -------------- 02328 ! 02329 WRITE (UNIT = kout,FMT = 1001) knulre 02330 ! 02331 !* Formats 02332 ! 02333 1001 FORMAT('Locread : Read binary file connected to unit = ',I4) 02334 ! 02335 ! 2. Find field in file 02336 ! ------------------ 02337 ! 02338 REWIND knulre 02339 200 CONTINUE 02340 !* Find string 02341 READ (UNIT = knulre, ERR = 200, END = 210) clecfl 02342 IF (clecfl .NE. cdfldn) GO TO 200 02343 !* Read associated field 02344 READ (UNIT = knulre, ERR = 210, END = 210) pfield 02345 !* Reading done and ok 02346 kflgre = 0 02347 GO TO 220 02348 !* Problem in reading 02349 210 kflgre = 1 02350 220 CONTINUE 02351 ! 02352 ! 02353 !* 3. End of routine 02354 ! -------------- 02355 ! 02356 ! 02357 #ifdef __VERBOSE 02358 WRITE(nulprt,*)'| | | Leaving routine locreadr8' 02359 WRITE(nulprt,*)' ' 02360 CALL FLUSH(nulprt) 02361 #endif 02362 ! 02363 RETURN 02364 END SUBROUTINE locreadr8 02365 02366 END module mod_prism_get_proto
1.7.4 
