|
Oasis3 4.0.2
|
|
Oasis3 4.0.2
|
00001 module mod_prism_put_proto 00002 #include "psmile_os.h" 00003 00004 interface prism_put_proto 00005 00006 #ifndef __NO_4BYTE_REALS 00007 module procedure prism_put_proto_r14 00008 module procedure prism_put_proto_r24 00009 #endif 00010 module procedure prism_put_proto_r18, & 00011 prism_put_proto_r28 00012 00013 end interface 00014 00015 contains 00016 #ifndef __NO_4BYTE_REALS 00017 SUBROUTINE prism_put_proto_r14(id_port_id,kstep,rd_field,kinfo) 00018 ! 00019 ! 00020 !* *** PRISM_put *** PRISM 1.0 00021 ! 00022 ! purpose: 00023 ! -------- 00024 ! give pfield to Oasis or models connected to port id_port_id at the 00025 ! time kstep 00026 ! 00027 ! interface: 00028 ! ---------- 00029 ! id_port_id : port number of the field 00030 ! kstep : current time in seconds 00031 ! rd_field : buffer of reals 00032 ! kinfo : output status 00033 ! 00034 ! lib mp: 00035 ! ------- 00036 ! mpi-1 00037 ! 00038 ! author: 00039 ! ------- 00040 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export) 00041 ! 00042 ! modified: 00043 ! --------- 00044 ! Reiner Vogelsang, SGI, 27 April 2003 00045 ! - Screening of 4 byte real interfaces in case a of dbl4 compilation. 00046 ! File has to be preprocessed with -D__SXdbl4. 00047 ! S. Legutke, MPI-HH M&D, 13 May 2003 00048 ! - return PRISM_Sent if a field was received 00049 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 00050 ! ---------------------------------------------------------------- 00051 USE mod_prism_proto 00052 USE mod_comprism_proto 00053 USE mathelp_psmile 00054 #if defined use_comm_GSIP 00055 USE mod_gsip_model 00056 #endif 00057 IMPLICIT NONE 00058 #if defined use_comm_MPI1 || defined use_comm_MPI2 00059 #include <mpif.h> 00060 #endif 00061 ! ---------------------------------------------------------------- 00062 INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id 00063 REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field 00064 ! ---------------------------------------------------------------- 00065 INTEGER (kind=ip_intwp_p) il_newtime 00066 INTEGER (kind=ip_intwp_p) info, ib 00067 INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb 00068 INTEGER (kind=ip_intwp_p) imod, itid, itag, il_len, ioff, ityp, ibyt 00069 INTEGER (kind=ip_intwp_p) iposbuf 00070 INTEGER (kind=ip_intwp_p) :: il_nbopp, il_nbin, il_nbout 00071 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10 00072 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1 00073 INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex) 00074 REAL(kind=ip_single_p) :: rl_tmp_scal(ip_nbopp_max) 00075 REAL(kind=ip_single_p),PARAMETER :: ip_missing_val=1.e20 00076 REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux 00077 CHARACTER(len=80) :: cl_topps, cl_str 00078 CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max) 00079 #ifdef use_comm_GSIP 00080 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 00081 INTEGER :: mgi_write 00082 #endif 00083 #ifdef balance 00084 CHARACTER(8) :: date 00085 CHARACTER(10) :: time 00086 CHARACTER(5) :: zone 00087 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 00088 REAL(kind=ip_double_p):: millisec 00089 REAL(kind=ip_double_p):: sec_date 00090 #endif 00091 ! ---------------------------------------------------------------- 00092 ! 00093 #ifdef __VERBOSE 00094 WRITE(nulprt,*) ' ' 00095 WRITE(nulprt,*) '| | | Entering prism_put_proto_r14 for field ',id_port_id 00096 call flush(nulprt) 00097 #endif 00098 ! 00099 rl_field_aux(:)=0 00100 cl_tmp_sopp(:)=' ' 00101 il_nindex(:)=0 00102 rl_tmp_scal(:)=0 00103 ! 00104 !* 0. Entering 00105 ! ----------- 00106 ! 00107 kinfo = PRISM_Ok 00108 IF (ip_realwp_p == ip_double_p) CALL prism_abort_proto (0,'prism_put_proto', & 00109 'STOP -- PSMILe compiled with double precision REAL; prism_put_proto_r14 should not be called') 00110 lg_dgfield = .false. 00111 ! 00112 !* 1. check for this port in my list 00113 ! --------------------------------- 00114 ! 00115 isend = 0 00116 iport = -1 00117 ! Test if the field is defined in the namcouple and if its coupling period 00118 ! is not greater than the time of the simulation. 00119 IF (ig_def_freq(id_port_id) .eq. 0.or. & 00120 ig_def_freq(id_port_id) .gt. ig_ntime) THEN 00121 GOTO 1010 00122 ENDIF 00123 ! 00124 ! 00125 ! if a field exported at a certain time should match an import 00126 ! at a time+lag, add the lag here; the lag is given by the user 00127 ! in the namcouple at the end of the field 2nd line. 00128 IF (myport(1,id_port_id).eq.CLIM_Out) THEN 00129 iport=id_port_id 00130 il_newtime = kstep + ig_def_lag(iport) 00131 ENDIF 00132 00133 IF (iport.lt.0) THEN 00134 kinfo = CLIM_BadPort 00135 WRITE(nulprt,FMT='(A,A)') & 00136 'Put - WARNING - Invalid port out: ', & 00137 cports(id_port_id) 00138 GO TO 1010 00139 ENDIF 00140 ! 00141 ! If the user indicated in the namcouple that the field must be 00142 ! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the 00143 ! end of the field 2nd line), do the local transformations. 00144 ! 00145 IF (ig_def_trans(iport) .EQ. ip_instant) THEN 00146 cl_str = 'inst(ident(X))' 00147 rg_field_trans(1:myport(4,id_port_id),iport) = rd_field (:) 00148 ELSEIF (ig_def_trans(iport) .eq. ip_average .or. & 00149 ig_def_trans(iport) .EQ. ip_accumul .OR. & 00150 ig_def_trans(iport) .EQ. ip_min .OR. & 00151 ig_def_trans(iport) .EQ. ip_max) THEN 00152 IF (ig_number(iport) .EQ. 0) rg_field_trans(:,iport) = 0 00153 il_nbin = myport(4,iport) 00154 il_nbout = il_nbin 00155 cl_topps = 'ave, inst, t_sum, t_min, t_max' 00156 IF (ig_def_trans(iport) .EQ. ip_average) THEN 00157 cl_str = 'ave(ident(X))' 00158 ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 00159 cl_str = 't_sum(ident(X))' 00160 ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN 00161 cl_str = 't_min(ident(X))' 00162 ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN 00163 cl_str = 't_max(ident(X))' 00164 ENDIF 00165 CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, & 00166 ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp) 00167 00168 CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, & 00169 ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, & 00170 rl_field_aux) 00171 00172 IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) & 00173 CALL moycum(cl_tmp_topp, il_nbin, rg_field_trans(:,iport), & 00174 rl_field_aux, ig_number(iport)) 00175 ig_number(iport) = ig_number(iport) + 1 00176 IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN 00177 ig_number(iport) = 0 00178 DO ib = 1, myport(4,iport) 00179 rd_field(ib) = rg_field_trans(ib,iport) 00180 ENDDO 00181 ENDIF 00182 kinfo = PRISM_LocTrans 00183 ENDIF 00184 ! 00185 !* Test if field must be written to restart file i.e. 00186 !* - current time is time at the end of simulation + 00187 !* - lag of current field is greater 0 00188 ! 00189 IF (il_newtime.EQ.ig_ntime.AND.ig_def_lag(iport).GT.0) THEN 00190 IF (ig_def_state(iport) .ne. ip_output) THEN 00191 ! 00192 !* Note: A model can have several restart files but same restart 00193 !* file can't be used by different models 00194 ! 00195 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 00196 CALL write_filer4(rd_field,cports(iport),iport) 00197 ELSE 00198 CALL write_file_parar4(rd_field,cports(iport),iport) 00199 ENDIF 00200 kinfo = PRISM_ToRest 00201 ENDIF 00202 ! Test if the current time is a coupling (or I/O) time 00203 IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN 00204 00205 #if !defined key_noIO 00206 !* If the user indicated in the namcouple that the field is 00207 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 00208 !* at the end of the field 1st line), do the writing to file here, e.g.: 00209 IF (ig_def_state(iport) .EQ. ip_output ) THEN 00210 CALL psmile_write_4(iport,rd_field,il_newtime) 00211 kinfo = PRISM_Output 00212 ELSEIF (ig_def_state(iport) .eq. ip_expout .or. & 00213 ig_def_state(iport) .EQ. ip_ignout) THEN 00214 CALL psmile_write_4(iport,rd_field,il_newtime) 00215 kinfo = PRISM_ToRestOut 00216 ENDIF 00217 #endif 00218 ENDIF 00219 ELSE 00220 ! Test if the current time is a coupling (or I/O) time 00221 IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN 00222 ! 00223 #if !defined key_noIO 00224 !* If the user indicated in the namcouple that the field is 00225 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 00226 !* at the end of the field 1st line), do the writing to file here, e.g.: 00227 IF (ig_def_state(iport) .EQ. ip_output .OR. & 00228 ig_def_state(iport) .EQ. ip_expout .OR. & 00229 ig_def_state(iport) .EQ. ip_ignout) THEN 00230 CALL psmile_write_4(iport,rd_field,il_newtime) 00231 kinfo = PRISM_Output 00232 ENDIF 00233 #endif 00234 !* 00235 !* If the user indicated in the namcouple that the field is 00236 !* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 00237 !* at the end of the field 1st line),do the export here. 00238 !* 00239 IF (ig_def_state(iport) .EQ. ip_expout .OR. & 00240 ig_def_state(iport) .eq. ip_exported .or. & 00241 ig_def_state(iport) .eq. ip_ignored .or. & 00242 ig_def_state(iport) .eq. ip_ignout .or. & 00243 ig_def_state(iport) .eq. ip_auxilary) THEN 00244 00245 ! 00246 !* check for connected ports (in) 00247 ! ------------------------------ 00248 ! 00249 ! #slo - Output reduced using option -D__SILENT in Cppflags_libs.h: 00250 #ifdef __VERBOSE 00251 WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport) 00252 CALL FLUSH(nulprt) 00253 #endif 00254 ! 00255 ityp = myport(2,iport) 00256 ibyt = myport(3,iport) 00257 #ifdef balance 00258 CALL date_and_time(date,time,zone,values) 00259 millisec=values(8) 00260 sec_date=millisec/1000+values(7)+values(6)*60+& 00261 values(5)*3600+values(3)*86400 00262 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00263 'Balance: ',cports(iport),'Before MPI put ',sec_date 00264 #endif 00265 ! 00266 DO ip=1,myport(5,iport) 00267 ! 00268 ilk = myport(5+ip,iport) 00269 imod = mylink(1,ilk) 00270 itid = mylink(2,ilk) 00271 itag = mylink(3,ilk) - il_newtime / ig_frqmin 00272 iseg = mylink(4,ilk) 00273 ! 00274 #if defined use_comm_MPI1 || defined use_comm_MPI2 00275 ilgb = 0 00276 iposbuf = 0 00277 DO is=1,iseg 00278 ioff = mylink(4+2*is-1,ilk) * 2 + 1 00279 il_len = mylink(4+2*is,ilk) 00280 ! 00281 IF ( ityp .EQ. PRISM_Real ) THEN 00282 CALL MPI_Pack ( rd_field(ioff), il_len, & 00283 MPI_REAL,pkwork_field, ig_maxtype_field, iposbuf, & 00284 mpi_comm, info ) 00285 ELSE 00286 WRITE(nulprt,*)'Put - pb type incorrect ', ityp 00287 kinfo = CLIM_BadType 00288 GO TO 1010 00289 ENDIF 00290 ilgb = ilgb + il_len 00291 ENDDO 00292 IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN 00293 kinfo = CLIM_Pack 00294 #ifdef __VERBOSE 00295 WRITE(nulprt,FMT='(A,I3,I8,A)') & 00296 'Put - pb pack<mpi ',info,ilgb*ibyt,'>' 00297 CALL FLUSH(nulprt) 00298 #endif 00299 ELSE 00300 !* 00301 IF (lg_clim_bsend) THEN 00302 !* Buffered send 00303 !* -> if fields are not sent and received in the same order, and 00304 !* and on architectures on which MPI_Send is not implemented with a 00305 !* mailbox (e.g. NEC SX5) 00306 !* 00307 CALL MPI_BSend ( pkwork_field, iposbuf, & 00308 MPI_PACKED, itid, itag, mpi_comm, info ) 00309 ELSE 00310 !* 00311 !* Standard blocking send: To be used 00312 !* -> if fields are necessarily sent and received in the same order, 00313 !* -> or on architectures on which MPI_Send is implemented with a 00314 !* mailbox (e.g. VPPs); in this case, make sure that your mailbox 00315 !* size is large enough. 00316 ! 00317 CALL MPI_Send ( pkwork_field, iposbuf, & 00318 MPI_PACKED, itid, itag, mpi_comm, info ) 00319 ! 00320 ENDIF 00321 ! 00322 IF (info.eq.CLIM_ok) THEN 00323 isend = isend + 1 00324 nbsend = nbsend + ilgb * ibyt 00325 #ifdef __VERBOSE 00326 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A,I6,A)') & 00327 'Put - <dest:',imod, & 00328 '> <step:',il_newtime, & 00329 '> <len:',ilgb, & 00330 '> <type:',ibyt, & 00331 '> <tag:',itag, & 00332 '> <comm:',mpi_comm,'>' 00333 CALL FLUSH(nulprt) 00334 #endif 00335 ELSE 00336 kinfo = CLIM_Pvm 00337 #ifdef __VERBOSE 00338 WRITE(nulprt,FMT='(A,I3,A)') & 00339 'Put - pb send <mpi ',info,'>' 00340 CALL FLUSH(nulprt) 00341 #endif 00342 ENDIF 00343 ENDIF 00344 #elif defined use_comm_GSIP 00345 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 00346 (0,'prism_put_proto', 'STOP -- only one send to Oasis, myport(5,iport) should be 1') 00347 if (imod .ne. 0) CALL prism_abort_proto & 00348 (0,'prism_get_proto', 'STOP -- if sent to Oasis, imod should be 0') 00349 if (itid .ne. 1) CALL prism_abort_proto & 00350 (0,'prism_get_proto', 'STOP -- if sent to Oasis, itid should be 1') 00351 ! 00352 ! Fill pkworkps with segments of rd_field 00353 ilgb = 0 00354 il_rst = 0 00355 il_ren = 0 00356 DO is=1,iseg 00357 ioff = mylink(4+2*is-1,ilk) + 1 00358 il_len = mylink(4+2*is,ilk) 00359 il_rst = il_ren + 1 00360 il_ren = il_rst + il_len - 1 00361 pkworkps(il_rst:il_ren) = rd_field(ioff:ioff+il_len-1) 00362 ! 00363 ilgb = ilgb + il_len 00364 ENDDO 00365 IF (ilgb .GT. ig_CLIMmax) THEN 00366 WRITE(UNIT = nulprt,FMT = *) & 00367 '1- prism_put_proto - error :', il_errgsip 00368 CALL prism_abort_proto (0, 'prism_put_proto', & 00369 'STOP - sum of segments greater than pkworkps size') 00370 ENDIF 00371 ! 00372 ! Write the field in channel to Oasis (no DIRECT communication) 00373 il_errgsip = mgi_write (ig_gsipw, pkworkps, ig_CLIMmax, 'R') 00374 IF (il_errgsip .GE. 0) THEN 00375 WRITE(UNIT = nulprt,FMT = *) & 00376 'prism_put_proto - pkworkps written OK:', il_errgsip 00377 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 00378 'Put - <dest:',imod, '> <step:',kstep,'> <len:', & 00379 ilgb, '> <type:',ibyt, '> <noproc:',itid,'>' 00380 isend = isend + 1 00381 ELSE 00382 WRITE(UNIT = nulprt,FMT = *) & 00383 '2- prism_put_proto - error :', il_errgsip 00384 CALL flush(nulprt) 00385 CALL prism_abort_proto (0, 'prism_put_proto', & 00386 'STOP - pkworkps not written OK)') 00387 ENDIF 00388 #endif 00389 ! 00390 ENDDO 00391 #ifdef balance 00392 CALL date_and_time(date,time,zone,values) 00393 millisec=values(8) 00394 sec_date=millisec/1000+values(7)+values(6)*60+& 00395 values(5)*3600+values(3)*86400 00396 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00397 'Balance: ',cports(iport),'After MPI put ',sec_date 00398 #endif 00399 ! 00400 IF (kinfo .EQ. PRISM_Output) THEN 00401 kinfo = PRISM_SentOut 00402 ELSE 00403 kinfo = PRISM_Sent 00404 ENDIF 00405 00406 #ifdef __VERBOSE 00407 WRITE(nulprt,FMT='(A,I3,A)') & 00408 'Put r14- ',isend,' fields exported' 00409 CALL FLUSH(nulprt) 00410 #endif 00411 ENDIF 00412 ENDIF 00413 ENDIF 00414 ! 00415 ! ---------------------------------------------------------------- 00416 ! 00417 1010 CONTINUE 00418 ! 00419 #ifdef __VERBOSE 00420 WRITE(nulprt,*)'| | | Leaving routine prism_put_proto_r14' 00421 WRITE(nulprt,*) ' ' 00422 CALL FLUSH(nulprt) 00423 #endif 00424 ! 00425 RETURN 00426 END SUBROUTINE prism_put_proto_r14 00427 #endif 00428 SUBROUTINE prism_put_proto_r18(id_port_id,kstep,rd_field,kinfo) 00429 ! 00430 !* *** PRISM_put *** PRISM 1.0 00431 ! 00432 ! purpose: 00433 ! -------- 00434 ! give rd_field to Oasis or models connected to port id_port_id at the 00435 ! time kstep 00436 ! 00437 ! interface: 00438 ! ---------- 00439 ! id_port_id : port number of the field 00440 ! kstep : current time in seconds 00441 ! rd_field : buffer of reals 00442 ! kinfo : output status 00443 ! 00444 ! lib mp: 00445 ! ------- 00446 ! mpi-1 or mpi-2 or gsip 00447 ! 00448 ! author: 00449 ! ------- 00450 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export) 00451 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 00452 ! ---------------------------------------------------------------- 00453 USE mod_kinds_model 00454 USE mod_prism_proto 00455 USE mod_comprism_proto 00456 USE mathelp_psmile 00457 #if defined use_comm_GSIP 00458 USE mod_gsip_model 00459 #endif 00460 IMPLICIT NONE 00461 #if defined use_comm_MPI1 || defined use_comm_MPI2 00462 #include <mpif.h> 00463 #endif 00464 ! ---------------------------------------------------------------- 00465 INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id 00466 REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field 00467 ! ---------------------------------------------------------------- 00468 INTEGER (kind=ip_intwp_p) il_newtime 00469 INTEGER (kind=ip_intwp_p) info 00470 INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb, & 00471 imod, itid, itag, il_len, ioff, ityp, ibyt 00472 INTEGER (kind=ip_intwp_p) iposbuf 00473 INTEGER (kind=ip_intwp_p) :: ib, il_nbopp, il_nbin, il_nbout 00474 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10 00475 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1 00476 INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex) 00477 REAL(kind=ip_double_p) :: rl_tmp_scal(ip_nbopp_max) 00478 REAL(kind=ip_double_p),PARAMETER :: ip_missing_val=1.e20 00479 REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux 00480 CHARACTER(len=80) :: cl_topps, cl_str 00481 CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max) 00482 #ifdef use_comm_GSIP 00483 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 00484 INTEGER :: mgi_write 00485 #endif 00486 #ifdef balance 00487 CHARACTER(8) :: date 00488 CHARACTER(10) :: time 00489 CHARACTER(5) :: zone 00490 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 00491 REAL(kind=ip_double_p):: millisec 00492 REAL(kind=ip_double_p):: sec_date 00493 #endif 00494 ! ---------------------------------------------------------------- 00495 ! 00496 #ifdef __VERBOSE 00497 WRITE(nulprt,*) ' ' 00498 WRITE(nulprt,*) '| | | Entering prism_put_proto_r18 for field ',id_port_id 00499 call flush(nulprt) 00500 #endif 00501 ! 00502 rl_field_aux(:)=0 00503 cl_tmp_sopp(:)=' ' 00504 il_nindex(:)=0 00505 rl_tmp_scal(:)=0 00506 ! 00507 !* 0. Entering 00508 ! ----------- 00509 ! 00510 kinfo = PRISM_Ok 00511 IF (ip_realwp_p == ip_single_p) CALL prism_abort_proto (0,'prism_put_proto', & 00512 'STOP -- PSMILe compiled with single precision REAL; prism_put_proto_r18 should not be called') 00513 lg_dgfield = .true. 00514 ! 00515 !* 1. check for this port in my list 00516 ! --------------------------------- 00517 ! 00518 isend = 0 00519 iport = -1 00520 ! 00521 ! Test if the field is defined in the namcouple and if its coupling period 00522 ! is not greater than the time of the simulation. 00523 IF (ig_def_freq(id_port_id) .eq. 0.or. & 00524 ig_def_freq(id_port_id) .gt. ig_ntime) THEN 00525 GOTO 1010 00526 ENDIF 00527 ! 00528 ! if a field exported at a certain time should match an import 00529 ! at a time+lag, add the lag here; the lag is given by the user 00530 ! in the namcouple at the end of the field 2nd line. 00531 IF (myport(1,id_port_id).eq.CLIM_Out) THEN 00532 iport=id_port_id 00533 il_newtime = kstep + ig_def_lag(iport) 00534 ENDIF 00535 00536 IF (iport.LT.0) THEN 00537 kinfo = CLIM_BadPort 00538 WRITE(nulprt,FMT='(A,A)') & 00539 'Put - WARNING - Invalid port out: ', & 00540 cports(id_port_id) 00541 GO TO 1010 00542 ENDIF 00543 ! 00544 ! If the user indicated in the namcouple that the field must be 00545 ! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the 00546 ! end of the field 2nd line), do the local transformations. 00547 ! 00548 IF (ig_def_trans(iport) .EQ. ip_instant) THEN 00549 cl_str = 'inst(ident(X))' 00550 dg_field_trans(1:myport(4,id_port_id),iport) = rd_field (:) 00551 ELSEIF (ig_def_trans(iport) .eq. ip_average .or. & 00552 ig_def_trans(iport) .EQ. ip_accumul .OR. & 00553 ig_def_trans(iport) .EQ. ip_min .OR. & 00554 ig_def_trans(iport) .EQ. ip_max) THEN 00555 IF (ig_number(iport) .EQ. 0) dg_field_trans(:,iport) = 0 00556 il_nbin = myport(4,iport) 00557 il_nbout = il_nbin 00558 cl_topps = 'ave, inst, t_sum, t_min, t_max' 00559 IF (ig_def_trans(iport) .EQ. ip_average) THEN 00560 cl_str = 'ave(ident(X))' 00561 ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 00562 cl_str = 't_sum(ident(X))' 00563 ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN 00564 cl_str = 't_min(ident(X))' 00565 ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN 00566 cl_str = 't_max(ident(X))' 00567 ENDIF 00568 CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, & 00569 ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp) 00570 00571 CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, & 00572 ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, & 00573 rl_field_aux) 00574 00575 IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) & 00576 CALL moycum(cl_tmp_topp, il_nbin, dg_field_trans(:,iport), & 00577 rl_field_aux, ig_number(iport)) 00578 ig_number(iport) = ig_number(iport) + 1 00579 IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN 00580 ig_number(iport) = 0 00581 DO ib = 1, myport(4,iport) 00582 rd_field(ib) = dg_field_trans(ib,iport) 00583 ENDDO 00584 ENDIF 00585 kinfo = PRISM_LocTrans 00586 ENDIF 00587 ! 00588 !* Test if field must be written to restart file i.e. 00589 !* - current time is time at the end of simulation + 00590 !* - lag of current field is greater 0 00591 ! 00592 IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN 00593 IF (ig_def_state(iport) .ne. ip_output) THEN 00594 ! 00595 !* Note: A model can have several restart files but same restart 00596 !* file can't be used by different models 00597 ! 00598 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 00599 CALL write_filer8(rd_field,cports(iport),iport) 00600 ELSE 00601 CALL write_file_parar8(rd_field,cports(iport),iport) 00602 ENDIF 00603 kinfo = PRISM_ToRest 00604 ENDIF 00605 ! Test if the current time is a coupling (or I/O) time 00606 IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN 00607 00608 #if !defined key_noIO 00609 !* If the user indicated in the namcouple that the field is 00610 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 00611 !* at the end of the field 1st line), do the writing to file here, e.g.: 00612 IF (ig_def_state(iport) .EQ. ip_output ) THEN 00613 CALL psmile_write_8(iport,rd_field,il_newtime) 00614 kinfo = PRISM_Output 00615 ELSEIF (ig_def_state(iport) .eq. ip_expout .or. & 00616 ig_def_state(iport) .EQ. ip_ignout) THEN 00617 CALL psmile_write_8(iport,rd_field,il_newtime) 00618 kinfo = PRISM_ToRestOut 00619 ENDIF 00620 #endif 00621 ENDIF 00622 ELSE 00623 00624 ! Test if the current time is a coupling (or I/O) time 00625 IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN 00626 ! 00627 #if !defined key_noIO 00628 !* If the user indicated in the namcouple that the field is 00629 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 00630 !* at the end of the field 1st line), do the writing to file here, e.g.: 00631 IF (ig_def_state(iport) .eq. ip_output .or. & 00632 ig_def_state(iport) .eq. ip_expout .or. & 00633 ig_def_state(iport) .eq. ip_ignout) THEN 00634 call psmile_write_8(iport,rd_field,il_newtime) 00635 kinfo = PRISM_Output 00636 ENDIF 00637 #endif 00638 !* 00639 !* If the user indicated in the namcouple that the field is 00640 !* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 00641 !* at the end of the field 1st line),do the export here. 00642 !* 00643 IF (ig_def_state(iport) .eq. ip_expout .or. & 00644 ig_def_state(iport) .eq. ip_exported .or. & 00645 ig_def_state(iport) .eq. ip_ignored .or. & 00646 ig_def_state(iport) .eq. ip_ignout .or. & 00647 ig_def_state(iport) .eq. ip_auxilary) THEN 00648 00649 ! 00650 !* check for connected ports (in) 00651 ! ------------------------------ 00652 ! 00653 #ifdef __VERBOSE 00654 WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport) 00655 CALL FLUSH(nulprt) 00656 #endif 00657 ! 00658 ityp = myport(2,iport) 00659 ibyt = myport(3,iport) 00660 #ifdef balance 00661 CALL date_and_time(date,time,zone,values) 00662 millisec=values(8) 00663 sec_date=millisec/1000+values(7)+values(6)*60+& 00664 values(5)*3600+values(3)*86400 00665 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00666 'Balance: ',cports(iport),'Before MPI put ',sec_date 00667 #endif 00668 ! 00669 DO ip=1,myport(5,iport) 00670 ! 00671 ilk = myport(5+ip,iport) 00672 ! imod is the distant model number 00673 imod = mylink(1,ilk) 00674 ! itid is the distant local process number 00675 itid = mylink(2,ilk) 00676 itag = mylink(3,ilk) - il_newtime / ig_frqmin 00677 iseg = mylink(4,ilk) 00678 ! 00679 #if defined use_comm_MPI1 || defined use_comm_MPI2 00680 ilgb = 0 00681 iposbuf = 0 00682 DO is=1,iseg 00683 ioff = mylink(4+2*is-1,ilk) + 1 00684 il_len = mylink(4+2*is,ilk) 00685 ! 00686 IF ( ityp .EQ. PRISM_Real ) THEN 00687 CALL MPI_Pack ( rd_field(ioff), il_len, & 00688 MPI_DOUBLE_PRECISION, pkwork_field, & 00689 ig_maxtype_field, iposbuf, & 00690 mpi_comm, info ) 00691 ELSE 00692 WRITE(nulprt,*)'Put - pb type incorrect ', ityp 00693 kinfo = CLIM_BadType 00694 GO TO 1010 00695 ENDIF 00696 ilgb = ilgb + il_len 00697 ENDDO 00698 IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN 00699 kinfo = CLIM_Pack 00700 WRITE(nulprt,FMT='(A,I3,I8,A)') & 00701 'Put - pb pack<mpi ',info,ilgb*ibyt,'>' 00702 ELSE 00703 IF (lg_clim_bsend) THEN 00704 !* 00705 !* Buffered send 00706 !* -> if fields are not sent and received in the same order, and 00707 !* and on architectures on which MPI_Send is not implemented with a 00708 !* mailbox (e.g. NEC SX5) 00709 !* 00710 CALL MPI_BSend ( pkwork_field, iposbuf, & 00711 MPI_PACKED, itid, itag, mpi_comm, info ) 00712 ELSE 00713 !* 00714 !* Standard blocking send: To be used 00715 !* -> if fields are necessarily sent and received in the same order, 00716 !* -> or on architectures on which MPI_Send is implemented with a 00717 !* mailbox (e.g. VPPs); in this case, make sure that your mailbox 00718 !* size is large enough. 00719 ! 00720 CALL MPI_Send ( pkwork_field, iposbuf, & 00721 MPI_PACKED, itid, itag, mpi_comm, info ) 00722 ! 00723 ENDIF 00724 ! 00725 IF (info.eq.CLIM_ok) THEN 00726 isend = isend + 1 00727 nbsend = nbsend + ilgb * ibyt 00728 #ifdef __VERBOSE 00729 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 00730 'Put - <dest:',imod, & 00731 '> <step:',il_newtime, & 00732 '> <len:',ilgb, & 00733 '> <type:',ibyt, & 00734 '> <tag:',itag,'>' 00735 CALL FLUSH(nulprt) 00736 #endif 00737 ELSE 00738 kinfo = CLIM_Pvm 00739 #ifdef __VERBOSE 00740 WRITE(nulprt,FMT='(A,I3,A)') & 00741 'Put - pb send <mpi ',info,'>' 00742 CALL FLUSH(nulprt) 00743 #endif 00744 ENDIF 00745 ENDIF 00746 #elif defined use_comm_GSIP 00747 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 00748 (0,'prism_put_proto', 'STOP -- only one send to Oasis, myport(5,iport) should be 1') 00749 if (imod .ne. 0) CALL prism_abort_proto & 00750 (0,'prism_get_proto', 'STOP -- if sent to Oasis, imod should be 0') 00751 if (itid .ne. 1) CALL prism_abort_proto & 00752 (0,'prism_get_proto', 'STOP -- if sent to Oasis, itid should be 1') 00753 ! 00754 ! Fill pkworkps with segments of rd_field 00755 ilgb = 0 00756 il_rst = 0 00757 il_ren = 0 00758 DO is=1,iseg 00759 ioff = mylink(4+2*is-1,ilk) + 1 00760 il_len = mylink(4+2*is,ilk) 00761 il_rst = il_ren + 1 00762 il_ren = il_rst + il_len - 1 00763 pkworkps(il_rst:il_ren) = rd_field(ioff:ioff+il_len-1) 00764 ! 00765 ilgb = ilgb + il_len 00766 ENDDO 00767 IF (ilgb .GT. ig_CLIMmax) THEN 00768 WRITE(UNIT = nulprt,FMT = *) & 00769 '1- prism_put_proto - error :', il_errgsip 00770 CALL prism_abort_proto (0, 'prism_put_proto', & 00771 'STOP - sum of segments greater than pkworkps size') 00772 ENDIF 00773 ! 00774 ! Write the field in channel to Oasis (no DIRECT communication) 00775 il_errgsip = mgi_write (ig_gsipw, pkworkps, ig_CLIMmax, 'D') 00776 IF (il_errgsip .GE. 0) THEN 00777 WRITE(UNIT = nulprt,FMT = *) & 00778 'prism_put_proto - pkworkps written OK:', il_errgsip 00779 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 00780 'Put - <dest:',imod, '> <step:',kstep,'> <len:', & 00781 ilgb, '> <type:',ibyt, '> <noproc:',itid,'>' 00782 isend = isend + 1 00783 ELSE 00784 WRITE(UNIT = nulprt,FMT = *) & 00785 '2- prism_put_proto - error :', il_errgsip 00786 CALL prism_abort_proto (0, 'prism_put_proto', & 00787 'STOP - pkworkps not written OK)') 00788 ENDIF 00789 #endif 00790 ENDDO 00791 #ifdef balance 00792 CALL date_and_time(date,time,zone,values) 00793 millisec=values(8) 00794 sec_date=millisec/1000+values(7)+values(6)*60+& 00795 values(5)*3600+values(3)*86400 00796 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 00797 'Balance: ',cports(iport),'After MPI put ',sec_date 00798 #endif 00799 ! 00800 IF (kinfo .EQ. PRISM_Output) THEN 00801 kinfo = PRISM_SentOut 00802 ELSE 00803 kinfo = PRISM_Sent 00804 ENDIF 00805 00806 #ifdef __VERBOSE 00807 WRITE(nulprt,FMT='(A,I3,A)') & 00808 'Put r18- ',isend,' fields exported' 00809 call flush(nulprt) 00810 #endif 00811 ENDIF 00812 ENDIF 00813 ENDIF 00814 ! 00815 ! ---------------------------------------------------------------- 00816 ! 00817 1010 CONTINUE 00818 #ifdef __VERBOSE 00819 WRITE(nulprt,*)'| | | Leaving routine prism_put_proto_r18' 00820 WRITE(nulprt,*) ' ' 00821 CALL FLUSH(nulprt) 00822 #endif 00823 RETURN 00824 END SUBROUTINE prism_put_proto_r18 00825 #ifndef __NO_4BYTE_REALS 00826 SUBROUTINE prism_put_proto_r24(id_port_id,kstep,rd_field_2d,kinfo) 00827 ! 00828 !* *** PRISM_put *** PRISM 1.0 00829 ! 00830 ! purpose: 00831 ! -------- 00832 ! give pfield to Oasis or models connected to port id_port_id at the 00833 ! time kstep 00834 ! 00835 ! interface: 00836 ! ---------- 00837 ! id_port_id : port number of the field 00838 ! kstep : current time in seconds 00839 ! rd_field : buffer of reals 00840 ! kinfo : output status 00841 ! 00842 ! lib mp: 00843 ! ------- 00844 ! mpi-1 00845 ! 00846 ! author: 00847 ! ------- 00848 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export) 00849 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 00850 ! ---------------------------------------------------------------- 00851 USE mod_kinds_model 00852 USE mod_prism_proto 00853 USE mod_comprism_proto 00854 USE mathelp_psmile 00855 #if defined use_comm_GSIP 00856 USE mod_gsip_model 00857 #endif 00858 IMPLICIT NONE 00859 #if defined use_comm_MPI1 || defined use_comm_MPI2 00860 #include <mpif.h> 00861 #endif 00862 ! ---------------------------------------------------------------- 00863 INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id 00864 REAL(kind=ip_single_p), DIMENSION(:,:) :: rd_field_2d 00865 ! ---------------------------------------------------------------- 00866 REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field 00867 00868 INTEGER (kind=ip_intwp_p) il_newtime 00869 INTEGER (kind=ip_intwp_p) info, ib 00870 INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb 00871 INTEGER (kind=ip_intwp_p) imod, itid, itag, il_len, ioff, ityp, ibyt 00872 INTEGER (kind=ip_intwp_p) iposbuf 00873 INTEGER (kind=ip_intwp_p) :: il_nbopp, il_nbin, il_nbout 00874 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10 00875 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1 00876 INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex) 00877 REAL(kind=ip_single_p) :: rl_tmp_scal(ip_nbopp_max) 00878 REAL(kind=ip_single_p),PARAMETER :: ip_missing_val=1.e20 00879 REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux 00880 CHARACTER(len=80) :: cl_topps, cl_str 00881 CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max) 00882 #ifdef use_comm_GSIP 00883 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 00884 INTEGER :: mgi_write 00885 #endif 00886 #ifdef balance 00887 CHARACTER(8) :: date 00888 CHARACTER(10) :: time 00889 CHARACTER(5) :: zone 00890 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 00891 REAL(kind=ip_double_p):: millisec 00892 REAL(kind=ip_double_p):: sec_date 00893 #endif 00894 ! ---------------------------------------------------------------- 00895 ! 00896 #ifdef __VERBOSE 00897 WRITE(nulprt,*) ' ' 00898 WRITE(nulprt,*) '| | | Entering prism_put_proto_r24 for field ',id_port_id 00899 call flush(nulprt) 00900 #endif 00901 ! 00902 rl_field_aux(:)=0 00903 cl_tmp_sopp(:)=' ' 00904 il_nindex(:)=0 00905 rl_tmp_scal(:)=0 00906 ! 00907 !* 0. Entering 00908 ! ----------- 00909 ! 00910 kinfo = PRISM_Ok 00911 IF (ip_realwp_p == ip_double_p) CALL prism_abort_proto (0,'prism_put_proto', & 00912 'STOP -- PSMILe compiled with double precision REAL; prism_put_proto_r24 should not be called') 00913 lg_dgfield = .false. 00914 ! 00915 !* 1. check for this port in my list 00916 ! --------------------------------- 00917 ! 00918 isend = 0 00919 iport = -1 00920 ! 00921 ! 00922 ! Test if the field is defined in the namcouple and if its coupling period 00923 ! is not greater than the time of the simulation. 00924 IF (ig_def_freq(id_port_id) .eq. 0 .or. & 00925 ig_def_freq(id_port_id) .gt. ig_ntime) THEN 00926 GOTO 1010 00927 ENDIF 00928 ! if a field exported at a certain time should match an import 00929 ! at a time+lag, add the lag here; the lag is given by the user 00930 ! in the namcouple at the end of the field 2nd line. 00931 IF (myport(1,id_port_id).eq.CLIM_Out) THEN 00932 iport=id_port_id 00933 il_newtime = kstep + ig_def_lag(iport) 00934 ENDIF 00935 00936 IF (iport.lt.0) THEN 00937 kinfo = CLIM_BadPort 00938 WRITE(nulprt,FMT='(A,A)') & 00939 'Put - WARNING - Invalid port out: ', & 00940 cports(id_port_id) 00941 GO TO 1010 00942 ENDIF 00943 ! 00944 ! Reshape 2d field 00945 ! 00946 rd_field(1:myport(4,id_port_id)) = RESHAPE (rd_field_2d(:,:), & 00947 (/myport(4,id_port_id)/)) 00948 ! 00949 ! If the user indicated in the namcouple that the field must be 00950 ! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the 00951 ! end of the field 2nd line), do the local transformations. 00952 ! 00953 IF (ig_def_trans(iport) .EQ. ip_instant) THEN 00954 cl_str = 'inst(ident(X))' 00955 rg_field_trans(1:myport(4,id_port_id),iport) = rd_field (:) 00956 ELSEIF (ig_def_trans(iport) .eq. ip_average .or. & 00957 ig_def_trans(iport) .EQ. ip_accumul .OR. & 00958 ig_def_trans(iport) .EQ. ip_min .OR. & 00959 ig_def_trans(iport) .EQ. ip_max) THEN 00960 IF (ig_number(iport) .EQ. 0) rg_field_trans(:,iport) = 0 00961 il_nbin = myport(4,iport) 00962 il_nbout = il_nbin 00963 cl_topps = 'ave, inst, t_sum, t_min, t_max' 00964 IF (ig_def_trans(iport) .EQ. ip_average) THEN 00965 cl_str = 'ave(ident(X))' 00966 ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 00967 cl_str = 't_sum(ident(X))' 00968 ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN 00969 cl_str = 't_min(ident(X))' 00970 ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN 00971 cl_str = 't_max(ident(X))' 00972 ENDIF 00973 CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, & 00974 ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp) 00975 00976 CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, & 00977 ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, & 00978 rl_field_aux) 00979 00980 IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) & 00981 CALL moycum(cl_tmp_topp, il_nbin, rg_field_trans(:,iport), & 00982 rl_field_aux, ig_number(iport)) 00983 ig_number(iport) = ig_number(iport) + 1 00984 IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN 00985 ig_number(iport) = 0 00986 DO ib = 1, myport(4,iport) 00987 rd_field(ib) = rg_field_trans(ib,iport) 00988 ENDDO 00989 ENDIF 00990 kinfo = PRISM_LocTrans 00991 ENDIF 00992 ! 00993 !* Test if field must be written to restart file i.e. 00994 !* - current time is time at the end of simulation + 00995 !* - lag of current field is greater 0 00996 ! 00997 IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN 00998 IF (ig_def_state(iport) .ne. ip_output) THEN 00999 ! 01000 !* Note: A model can have several restart files but same restart 01001 !* file can't be used by different models 01002 ! 01003 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 01004 CALL write_filer4(rd_field,cports(iport),iport) 01005 ELSE 01006 CALL write_file_parar4(rd_field,cports(iport),iport) 01007 ENDIF 01008 kinfo = PRISM_ToRest 01009 ENDIF 01010 ! Test if the current time is a coupling (or I/O) time 01011 IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN 01012 01013 #if !defined key_noIO 01014 !* If the user indicated in the namcouple that the field is 01015 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 01016 !* at the end of the field 1st line), do the writing to file here, e.g.: 01017 IF (ig_def_state(iport) .EQ. ip_output ) THEN 01018 CALL psmile_write_4(iport,rd_field,il_newtime) 01019 kinfo = PRISM_Output 01020 ELSEIF (ig_def_state(iport) .eq. ip_expout .or. & 01021 ig_def_state(iport) .EQ. ip_ignout) THEN 01022 CALL psmile_write_4(iport,rd_field,il_newtime) 01023 kinfo = PRISM_ToRestOut 01024 ENDIF 01025 #endif 01026 ENDIF 01027 ELSE 01028 ! Test if the current time is a coupling (or I/O) time 01029 IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN 01030 ! 01031 #if !defined key_noIO 01032 !* If the user indicated in the namcouple that the field is 01033 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 01034 !* at the end of the field 1st line), do the writing to file here, e.g.: 01035 IF (ig_def_state(iport) .EQ. ip_output .OR. & 01036 ig_def_state(iport) .eq. ip_expout .or. & 01037 ig_def_state(iport) .EQ. ip_ignout) THEN 01038 CALL psmile_write_4(iport,rd_field,il_newtime) 01039 kinfo = PRISM_Output 01040 ENDIF 01041 #endif 01042 !* 01043 !* If the user indicated in the namcouple that the field is 01044 !* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 01045 !* at the end of the field 1st line),do the export here. 01046 !* 01047 IF (ig_def_state(iport) .eq. ip_expout .or. & 01048 ig_def_state(iport) .eq. ip_exported .or. & 01049 ig_def_state(iport) .eq. ip_ignored .or. & 01050 ig_def_state(iport) .eq. ip_ignout .or. & 01051 ig_def_state(iport) .eq. ip_auxilary) THEN 01052 ! 01053 !* check for connected ports (in) 01054 ! ------------------------------ 01055 ! 01056 #ifdef __VERBOSE 01057 WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport) 01058 #endif 01059 ! 01060 ityp = myport(2,iport) 01061 ibyt = myport(3,iport) 01062 ! 01063 #ifdef balance 01064 CALL date_and_time(date,time,zone,values) 01065 millisec=values(8) 01066 sec_date=millisec/1000+values(7)+values(6)*60+& 01067 values(5)*3600+values(3)*86400 01068 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 01069 'Balance: ',cports(iport),'Before MPI put ',sec_date 01070 #endif 01071 DO ip=1,myport(5,iport) 01072 ! 01073 ilk = myport(5+ip,iport) 01074 imod = mylink(1,ilk) 01075 itid = mylink(2,ilk) 01076 itag = mylink(3,ilk) - il_newtime / ig_frqmin 01077 iseg = mylink(4,ilk) 01078 ! 01079 #if defined use_comm_MPI1 || defined use_comm_MPI2 01080 ilgb = 0 01081 iposbuf = 0 01082 DO is=1,iseg 01083 ioff = mylink(4+2*is-1,ilk) * 2 + 1 01084 il_len = mylink(4+2*is,ilk) 01085 ! 01086 IF ( ityp .EQ. PRISM_Real ) THEN 01087 CALL MPI_Pack ( rd_field(ioff), il_len, & 01088 MPI_REAL,pkwork_field, ig_maxtype_field, iposbuf, & 01089 mpi_comm, info ) 01090 ELSE 01091 WRITE(nulprt,*)'Put - pb type incorrect ', ityp 01092 kinfo = CLIM_BadType 01093 GO TO 1010 01094 ENDIF 01095 ilgb = ilgb + il_len 01096 ENDDO 01097 IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN 01098 kinfo = CLIM_Pack 01099 WRITE(nulprt,FMT='(A,I3,I8,A)') & 01100 'Put - pb pack<mpi ',info,ilgb*ibyt,'>' 01101 ELSE 01102 IF (lg_clim_bsend) THEN 01103 !* 01104 !* Buffered send 01105 !* -> if fields are not sent and received in the same order, and 01106 !* and on architectures on which MPI_Send is not implemented with a 01107 !* mailbox (e.g. NEC SX5) 01108 !* 01109 CALL MPI_BSend ( pkwork_field, iposbuf, MPI_PACKED, & 01110 itid, itag, mpi_comm, info ) 01111 ELSE 01112 !* 01113 !* Standard blocking send: To be used 01114 !* -> if fields are necessarily sent and received in the same order, 01115 !* -> or on architectures on which MPI_Send is implemented with a 01116 !* mailbox (e.g. VPPs); in this case, make sure that your mailbox 01117 !* size is large enough. 01118 ! 01119 CALL MPI_Send ( pkwork_field, iposbuf, MPI_PACKED, & 01120 itid, itag, mpi_comm, info ) 01121 ! 01122 ENDIF 01123 ! 01124 IF (info.eq.CLIM_ok) THEN 01125 isend = isend + 1 01126 nbsend = nbsend + ilgb * ibyt 01127 #ifdef __VERBOSE 01128 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01129 'Put - <dest:',imod, & 01130 '> <step:',il_newtime, & 01131 '> <len:',ilgb, & 01132 '> <type:',ibyt, & 01133 '> <tag:',itag,'>' 01134 #endif 01135 ELSE 01136 kinfo = CLIM_Pvm 01137 WRITE(nulprt,FMT='(A,I3,A)') & 01138 'Put - pb send <mpi ',info,'>' 01139 ENDIF 01140 ENDIF 01141 ! 01142 #elif defined use_comm_GSIP 01143 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 01144 (0,'prism_put_proto', 'STOP -- only one send to Oasis, myport(5,iport) should be 1') 01145 if (imod .ne. 0) CALL prism_abort_proto & 01146 (0,'prism_get_proto', 'STOP -- if sent to Oasis, imod should be 0') 01147 if (itid .ne. 1) CALL prism_abort_proto & 01148 (0,'prism_get_proto', 'STOP -- if sent to Oasis, itid should be 1') 01149 ! 01150 ! Fill pkworkps with segments of rd_field 01151 ilgb = 0 01152 il_rst = 0 01153 il_ren = 0 01154 DO is=1,iseg 01155 ioff = mylink(4+2*is-1,ilk) + 1 01156 il_len = mylink(4+2*is,ilk) 01157 il_rst = il_ren + 1 01158 il_ren = il_rst + il_len - 1 01159 pkworkps(il_rst:il_ren) = rd_field(ioff:ioff+il_len-1) 01160 ! 01161 ilgb = ilgb + il_len 01162 ENDDO 01163 IF (ilgb .GT. ig_CLIMmax) THEN 01164 WRITE(UNIT = nulprt,FMT = *) & 01165 '1- prism_put_proto - error :', il_errgsip 01166 CALL prism_abort_proto (0, 'prism_put_proto', & 01167 'STOP - sum of segments greater than pkworkps size') 01168 ENDIF 01169 ! 01170 ! Write the field in channel to Oasis (no DIRECT communication) 01171 il_errgsip = mgi_write (ig_gsipw, pkworkps, ig_CLIMmax, 'R') 01172 IF (il_errgsip .GE. 0) THEN 01173 WRITE(UNIT = nulprt,FMT = *) & 01174 'prism_put_proto - pkworkps written OK:', il_errgsip 01175 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01176 'Put - <dest:',imod, '> <step:',kstep,'> <len:', & 01177 ilgb, '> <type:',ibyt, '> <noproc:',itid,'>' 01178 isend = isend + 1 01179 ELSE 01180 WRITE(UNIT = nulprt,FMT = *) & 01181 '2- prism_put_proto - error :', il_errgsip 01182 CALL prism_abort_proto (0, 'prism_put_proto', & 01183 'STOP - pkworkps not written OK)') 01184 ENDIF 01185 #endif 01186 ENDDO 01187 #ifdef balance 01188 CALL date_and_time(date,time,zone,values) 01189 millisec=values(8) 01190 sec_date=millisec/1000+values(7)+values(6)*60+& 01191 values(5)*3600+values(3)*86400 01192 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 01193 'Balance: ',cports(iport),'After MPI put ',sec_date 01194 #endif 01195 ! 01196 IF (kinfo .EQ. PRISM_Output) THEN 01197 kinfo = PRISM_SentOut 01198 ELSE 01199 kinfo = PRISM_Sent 01200 ENDIF 01201 01202 #ifdef __VERBOSE 01203 WRITE(nulprt,FMT='(A,I3,A)') & 01204 'Put r24- ',isend,' fields exported' 01205 CALL FLUSH(nulprt) 01206 #endif 01207 ENDIF 01208 ENDIF 01209 ENDIF 01210 ! 01211 ! ---------------------------------------------------------------- 01212 ! 01213 1010 CONTINUE 01214 ! 01215 #ifdef __VERBOSE 01216 WRITE(nulprt,*)'| | | Leaving routine prism_put_proto_r24' 01217 WRITE(nulprt,*) ' ' 01218 CALL FLUSH(nulprt) 01219 #endif 01220 ! 01221 RETURN 01222 END SUBROUTINE prism_put_proto_r24 01223 #endif 01224 SUBROUTINE prism_put_proto_r28(id_port_id,kstep,rd_field_2d,kinfo) 01225 ! 01226 !* *** PRISM_put *** PRISM 1.0 01227 ! 01228 ! purpose: 01229 ! -------- 01230 ! give rd_field to Oasis or models connected to port id_port_id at the 01231 ! time kstep 01232 ! 01233 ! interface: 01234 ! ---------- 01235 ! id_port_id : port number of the field 01236 ! kstep : current time in seconds 01237 ! rd_field : buffer of reals 01238 ! kinfo : output status 01239 ! 01240 ! lib mp: 01241 ! ------- 01242 ! mpi-1 01243 ! 01244 ! author: 01245 ! ------- 01246 ! Arnaud Caubel - Fecit (08/02 - created from CLIM_Export) 01247 ! S. Valcke, CERFACS, 24/10/2004: Added GSIP 01248 ! ---------------------------------------------------------------- 01249 USE mod_kinds_model 01250 USE mod_prism_proto 01251 USE mod_comprism_proto 01252 USE mathelp_psmile 01253 #if defined use_comm_GSIP 01254 USE mod_gsip_model 01255 #endif 01256 IMPLICIT NONE 01257 #if defined use_comm_MPI1 || defined use_comm_MPI2 01258 #include <mpif.h> 01259 #endif 01260 ! ---------------------------------------------------------------- 01261 INTEGER (kind=ip_intwp_p) kstep, kinfo, id_port_id 01262 REAL(kind=ip_double_p), DIMENSION(:,:) :: rd_field_2d 01263 ! ---------------------------------------------------------------- 01264 REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field 01265 INTEGER (kind=ip_intwp_p) il_newtime 01266 INTEGER (kind=ip_intwp_p) info 01267 INTEGER (kind=ip_intwp_p) isend, ip, iport, ilk, iseg, is, ilgb, & 01268 imod, itid, itag, il_len, ioff, ityp, ibyt 01269 INTEGER (kind=ip_intwp_p) iposbuf 01270 INTEGER (kind=ip_intwp_p) :: ib, il_nbopp, il_nbin, il_nbout 01271 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbopp_max = 10 01272 INTEGER (kind=ip_intwp_p), PARAMETER :: ip_nbindex=1 01273 INTEGER (kind=ip_intwp_p) :: il_nindex(ip_nbindex) 01274 REAL(kind=ip_double_p) :: rl_tmp_scal(ip_nbopp_max) 01275 REAL(kind=ip_double_p),PARAMETER :: ip_missing_val=1.e20 01276 REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rl_field_aux 01277 CHARACTER(len=80) :: cl_topps, cl_str 01278 CHARACTER(len=7) :: cl_tmp_topp, cl_tmp_sopp(ip_nbopp_max) 01279 #ifdef use_comm_GSIP 01280 INTEGER(kind=ip_intwp_p) :: il_rst, il_ren, il_errgsip 01281 INTEGER :: mgi_write 01282 #endif 01283 #ifdef balance 01284 CHARACTER(8) :: date 01285 CHARACTER(10) :: time 01286 CHARACTER(5) :: zone 01287 INTEGER(kind=ip_intwp_p) ,DIMENSION(8) :: values 01288 REAL(kind=ip_double_p):: millisec 01289 REAL(kind=ip_double_p):: sec_date 01290 #endif 01291 ! ---------------------------------------------------------------- 01292 ! 01293 #ifdef __VERBOSE 01294 WRITE(nulprt,*) ' ' 01295 WRITE(nulprt,*) '| | | Entering prism_put_proto_r28 for field ',id_port_id 01296 call flush(nulprt) 01297 #endif 01298 ! 01299 rl_field_aux(:)=0 01300 cl_tmp_sopp(:)=' ' 01301 il_nindex(:)=0 01302 rl_tmp_scal(:)=0 01303 ! 01304 !* 0. Entering 01305 ! ----------- 01306 ! 01307 kinfo = PRISM_Ok 01308 IF (ip_realwp_p == ip_single_p) CALL prism_abort_proto (0,'prism_put_proto', & 01309 'STOP -- PSMILe compiled with single precision REAL; prism_put_proto_r28 should not be called') 01310 lg_dgfield = .true. 01311 ! 01312 !* 1. check for this port in my list 01313 ! --------------------------------- 01314 ! 01315 isend = 0 01316 iport = -1 01317 ! 01318 ! 01319 ! Test if the field is defined in the namcouple and if its coupling period 01320 ! is not greater than the time of the simulation. 01321 IF (ig_def_freq(id_port_id) .eq. 0 .or. & 01322 ig_def_freq(id_port_id) .gt. ig_ntime) THEN 01323 GOTO 1010 01324 ENDIF 01325 ! if a field exported at a certain time should match an import 01326 ! at a time+lag, add the lag here; the lag is given by the user 01327 ! in the namcouple at the end of the field 2nd line. 01328 IF (myport(1,id_port_id).eq.CLIM_Out) THEN 01329 iport=id_port_id 01330 il_newtime = kstep + ig_def_lag(iport) 01331 ENDIF 01332 IF (iport.lt.0) THEN 01333 kinfo = CLIM_BadPort 01334 WRITE(nulprt,FMT='(A,A)') & 01335 'Put - WARNING - Invalid port out: ', & 01336 cports(id_port_id) 01337 GO TO 1010 01338 ENDIF 01339 ! 01340 ! Reshape the 2d field 01341 ! 01342 rd_field(1:myport(4,id_port_id)) = RESHAPE (rd_field_2d(:,:), & 01343 (/myport(4,id_port_id)/)) 01344 ! 01345 ! If the user indicated in the namcouple that the field must be 01346 ! accumulated or averaged (keyword 'AVERAGE' or 'ACCUMUL' at the 01347 ! end of the field 2nd line), do the local transformations. 01348 ! 01349 IF (ig_def_trans(iport) .EQ. ip_instant) THEN 01350 cl_str = 'inst(ident(X))' 01351 dg_field_trans(1:myport(4,id_port_id),iport) = rd_field (:) 01352 ELSEIF (ig_def_trans(iport) .EQ. ip_average .OR. & 01353 ig_def_trans(iport) .EQ. ip_accumul .OR. & 01354 ig_def_trans(iport) .EQ. ip_min .OR. & 01355 ig_def_trans(iport) .EQ. ip_max) THEN 01356 IF (ig_number(iport) .EQ. 0) dg_field_trans(:,iport) = 0 01357 il_nbin = myport(4,iport) 01358 il_nbout = il_nbin 01359 cl_topps = 'ave, inst, t_sum, t_min, t_max' 01360 IF (ig_def_trans(iport) .EQ. ip_average) THEN 01361 cl_str = 'ave(ident(X))' 01362 ELSEIF (ig_def_trans(iport) .EQ. ip_accumul) THEN 01363 cl_str = 't_sum(ident(X))' 01364 ELSEIF (ig_def_trans(iport) .EQ. ip_min) THEN 01365 cl_str = 't_min(ident(X))' 01366 ELSEIF (ig_def_trans(iport) .EQ. ip_max) THEN 01367 cl_str = 't_max(ident(X))' 01368 ENDIF 01369 CALL buildop (cl_str,cl_topps,cl_tmp_topp,ip_nbopp_max, & 01370 ip_missing_val,cl_tmp_sopp,rl_tmp_scal,il_nbopp) 01371 01372 CALL mathop (cl_tmp_sopp(1), il_nbin, rd_field, ip_missing_val, & 01373 ip_nbindex, il_nindex, rl_tmp_scal(1), il_nbout, & 01374 rl_field_aux) 01375 01376 IF ((cl_tmp_topp(:LEN_TRIM(cl_tmp_topp)) .NE. 'inst')) & 01377 CALL moycum(cl_tmp_topp, il_nbin, dg_field_trans(:,iport), & 01378 rl_field_aux, ig_number(iport)) 01379 ig_number(iport) = ig_number(iport) + 1 01380 IF (MOD(il_newtime,ig_def_freq(iport)) .EQ. 0) THEN 01381 ig_number(iport) = 0 01382 DO ib = 1, myport(4,iport) 01383 rd_field(ib) = dg_field_trans(ib,iport) 01384 ENDDO 01385 ENDIF 01386 kinfo = PRISM_LocTrans 01387 ENDIF 01388 ! 01389 !* Test if field must be written to restart file i.e. 01390 !* - current time is time at the end of simulation + 01391 !* - lag of current field is greater from 0 01392 ! 01393 IF (il_newtime.eq.ig_ntime.and.ig_def_lag(iport).gt.0) THEN 01394 IF (ig_def_state(iport) .ne. ip_output) THEN 01395 ! 01396 !* Note: A model can have several restart files but same restart 01397 !* file can't be used by different models 01398 ! 01399 IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN 01400 CALL write_filer8(rd_field,cports(iport),iport) 01401 ELSE 01402 CALL write_file_parar8(rd_field,cports(iport),iport) 01403 ENDIF 01404 kinfo = PRISM_ToRest 01405 ENDIF 01406 ! Test if the current time is a coupling (or I/O) time 01407 IF (MOD(il_newtime,ig_def_freq(iport)).EQ.0) THEN 01408 01409 #if !defined key_noIO 01410 !* If the user indicated in the namcouple that the field is 01411 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 01412 !* at the end of the field 1st line), do the writing to file here, e.g.: 01413 IF (ig_def_state(iport) .EQ. ip_output ) THEN 01414 CALL psmile_write_8(iport,rd_field,il_newtime) 01415 kinfo = PRISM_Output 01416 ELSEIF (ig_def_state(iport) .eq. ip_expout .or. & 01417 ig_def_state(iport) .EQ. ip_ignout) THEN 01418 CALL psmile_write_8(iport,rd_field,il_newtime) 01419 kinfo = PRISM_ToRestOut 01420 ENDIF 01421 ! IF (ig_def_state(iport) .EQ. ip_output .OR. & 01422 ! ig_def_state(iport) .eq. ip_expout .or. & 01423 ! ig_def_state(iport) .EQ. ip_ignout) THEN 01424 ! CALL psmile_write_8(iport,rd_field,il_newtime) 01425 ! kinfo = PRISM_ToRestOut 01426 ! ENDIF 01427 #endif 01428 ENDIF 01429 ELSE 01430 01431 ! Test if the current time is a coupling (or I/O) time 01432 IF (mod(il_newtime,ig_def_freq(iport)).eq.0) THEN 01433 ! 01434 #if !defined key_noIO 01435 !* If the user indicated in the namcouple that the field is 01436 !* a field output-to-file (keyword 'OUTPUT', 'IGNOUT' or 'EXPOUT' 01437 !* at the end of the field 1st line), do the writing to file here, e.g.: 01438 IF (ig_def_state(iport) .EQ. ip_output .OR. & 01439 ig_def_state(iport) .eq. ip_expout .or. & 01440 ig_def_state(iport) .eq. ip_ignout) THEN 01441 call psmile_write_8(iport,rd_field,il_newtime) 01442 kinfo = PRISM_Output 01443 ENDIF 01444 #endif 01445 !* 01446 !* If the user indicated in the namcouple that the field is 01447 !* a coupling field (keyword EXPORTED','EXPOUT','IGNORED' or 'IGNOUT' 01448 !* at the end of the field 1st line),do the export here. 01449 !* 01450 IF (ig_def_state(iport) .eq. ip_expout .or. & 01451 ig_def_state(iport) .eq. ip_exported .or. & 01452 ig_def_state(iport) .eq. ip_ignored .or. & 01453 ig_def_state(iport) .eq. ip_ignout .or. & 01454 ig_def_state(iport) .eq. ip_auxilary) THEN 01455 ! 01456 !* check for connected ports (in) 01457 ! ------------------------------ 01458 ! 01459 #ifdef __VERBOSE 01460 WRITE(nulprt,FMT='(A,A)') 'Put - ', cports(iport) 01461 CALL FLUSH(nulprt) 01462 #endif 01463 ! 01464 ityp = myport(2,iport) 01465 ibyt = myport(3,iport) 01466 ! 01467 #ifdef balance 01468 CALL date_and_time(date,time,zone,values) 01469 millisec=values(8) 01470 sec_date=millisec/1000+values(7)+values(6)*60+& 01471 values(5)*3600+values(3)*86400 01472 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 01473 'Balance: ',cports(iport),'Before MPI put ',sec_date 01474 #endif 01475 DO ip=1,myport(5,iport) 01476 ! 01477 ilk = myport(5+ip,iport) 01478 imod = mylink(1,ilk) 01479 itid = mylink(2,ilk) 01480 itag = mylink(3,ilk) - il_newtime / ig_frqmin 01481 iseg = mylink(4,ilk) 01482 ! 01483 #if defined use_comm_MPI1 || defined use_comm_MPI2 01484 ilgb = 0 01485 iposbuf = 0 01486 DO is=1,iseg 01487 ioff = mylink(4+2*is-1,ilk) + 1 01488 il_len = mylink(4+2*is,ilk) 01489 ! 01490 IF ( ityp .EQ. PRISM_Real ) THEN 01491 CALL MPI_Pack(rd_field(ioff),il_len, & 01492 MPI_DOUBLE_PRECISION, & 01493 pkwork_field, ig_maxtype_field, iposbuf, & 01494 mpi_comm, info ) 01495 ELSE 01496 WRITE(nulprt,*)'Put - pb type incorrect ', ityp 01497 kinfo = CLIM_BadType 01498 GO TO 1010 01499 ENDIF 01500 ilgb = ilgb + il_len 01501 ENDDO 01502 IF (info.ne.0 .or. ilgb*ibyt .gt. ig_maxtype_field) THEN 01503 kinfo = CLIM_Pack 01504 WRITE(nulprt,FMT='(A,I3,I8,A)') & 01505 'Put - pb pack<mpi ',info,ilgb*ibyt,'>' 01506 ELSE 01507 IF (lg_clim_bsend) THEN 01508 !* 01509 !* Buffered send 01510 !* -> if fields are not sent and received in the same order, and 01511 !* and on architectures on which MPI_Send is not implemented with a 01512 !* mailbox (e.g. NEC SX5) 01513 !* 01514 CALL MPI_BSend ( pkwork_field, iposbuf, & 01515 MPI_PACKED, itid, itag, mpi_comm, info ) 01516 ELSE 01517 !* 01518 !* Standard blocking send: To be used 01519 !* -> if fields are necessarily sent and received in the same order, 01520 !* -> or on architectures on which MPI_Send is implemented with a 01521 !* mailbox (e.g. VPPs); in this case, make sure that your mailbox 01522 !* size is large enough. 01523 ! 01524 CALL MPI_Send ( pkwork_field, iposbuf, & 01525 MPI_PACKED, itid, itag, mpi_comm, info ) 01526 ! 01527 ENDIF 01528 ! 01529 IF (info.eq.CLIM_ok) THEN 01530 isend = isend + 1 01531 nbsend = nbsend + ilgb * ibyt 01532 #ifdef __VERBOSE 01533 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01534 'Put - <dest:',imod, & 01535 '> <step:',il_newtime, & 01536 '> <len:',ilgb, & 01537 '> <type:',ibyt, & 01538 '> <tag:',itag,'>' 01539 call flush(nulprt) 01540 #endif 01541 ELSE 01542 kinfo = CLIM_Pvm 01543 WRITE(nulprt,FMT='(A,I3,A)') & 01544 'Put - pb send <mpi ',info,'>' 01545 ENDIF 01546 ENDIF 01547 ! 01548 #elif defined use_comm_GSIP 01549 if (myport(5,iport) .ne. 1) CALL prism_abort_proto & 01550 (0,'prism_put_proto', 'STOP -- only one send to Oasis, myport(5,iport) should be 1') 01551 if (imod .ne. 0) CALL prism_abort_proto & 01552 (0,'prism_get_proto', 'STOP -- if sent to Oasis, imod should be 0') 01553 if (itid .ne. 1) CALL prism_abort_proto & 01554 (0,'prism_get_proto', 'STOP -- if sent to Oasis, itid should be 1') 01555 ! 01556 ! Fill pkworkps with segments of rd_field 01557 ilgb = 0 01558 il_rst = 0 01559 il_ren = 0 01560 DO is=1,iseg 01561 ioff = mylink(4+2*is-1,ilk) + 1 01562 il_len = mylink(4+2*is,ilk) 01563 il_rst = il_ren + 1 01564 il_ren = il_rst + il_len - 1 01565 pkworkps(il_rst:il_ren) = rd_field(ioff:ioff+il_len-1) 01566 ! 01567 ilgb = ilgb + il_len 01568 ENDDO 01569 IF (ilgb .GT. ig_CLIMmax) THEN 01570 WRITE(UNIT = nulprt,FMT = *) & 01571 '1- prism_put_proto - error :', il_errgsip 01572 CALL prism_abort_proto (0, 'prism_put_proto', & 01573 'STOP - sum of segments greater than pkworkps size') 01574 ENDIF 01575 ! 01576 ! Write the field in channel to Oasis (no DIRECT communication) 01577 il_errgsip = mgi_write (ig_gsipw, pkworkps, ig_CLIMmax, 'D') 01578 IF (il_errgsip .GE. 0) THEN 01579 WRITE(UNIT = nulprt,FMT = *) & 01580 'prism_put_proto - pkworkps written OK:', il_errgsip 01581 WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') & 01582 'Put - <dest:',imod, '> <step:',kstep,'> <len:', & 01583 ilgb, '> <type:',ibyt, '> <noproc:',itid,'>' 01584 isend = isend + 1 01585 ELSE 01586 WRITE(UNIT = nulprt,FMT = *) & 01587 '2- prism_put_proto - error :', il_errgsip 01588 CALL prism_abort_proto (0, 'prism_put_proto', & 01589 'STOP - pkworkps not written OK)') 01590 ENDIF 01591 #endif 01592 ENDDO 01593 #ifdef balance 01594 CALL date_and_time(date,time,zone,values) 01595 millisec=values(8) 01596 sec_date=millisec/1000+values(7)+values(6)*60+& 01597 values(5)*3600+values(3)*86400 01598 WRITE(nulprt, FMT='(A,A,A,F11.3)') & 01599 'Balance: ',cports(iport),'After MPI put ',sec_date 01600 #endif 01601 ! 01602 IF (kinfo .EQ. PRISM_Output) THEN 01603 kinfo = PRISM_SentOut 01604 ELSE 01605 kinfo = PRISM_Sent 01606 ENDIF 01607 01608 #ifdef __VERBOSE 01609 WRITE(nulprt,FMT='(A,I3,A)') & 01610 'Put r28 - ',isend,' fields exported' 01611 CALL FLUSH(nulprt) 01612 #endif 01613 ENDIF 01614 ENDIF 01615 ENDIF 01616 ! 01617 ! ---------------------------------------------------------------- 01618 ! 01619 1010 CONTINUE 01620 ! 01621 #ifdef __VERBOSE 01622 WRITE(nulprt,*)'| | | Leaving routine prism_put_proto_r28' 01623 WRITE(nulprt,*) ' ' 01624 CALL FLUSH(nulprt) 01625 #endif 01626 ! 01627 RETURN 01628 END SUBROUTINE prism_put_proto_r28 01629 01630 end module mod_prism_put_proto 01631
1.7.4 
