| 1 | subroutine MPP_WRITE_2DDECOMP_1D_( unit, field, domain, data, tstamp ) |
|---|
| 2 | integer, intent(in) :: unit |
|---|
| 3 | type(fieldtype), intent(in) :: field |
|---|
| 4 | type(domain2D), intent(inout) :: domain |
|---|
| 5 | MPP_TYPE_, intent(inout) :: data(:) |
|---|
| 6 | real(DOUBLE_KIND), intent(in), optional :: tstamp |
|---|
| 7 | integer::il_xbegin,il_xend,il_ybegin,il_yend,ij |
|---|
| 8 | MPP_TYPE_,allocatable :: data3D(:,:,:) |
|---|
| 9 | call mpp_get_compute_domain(domain & |
|---|
| 10 | ,xbegin=il_xbegin,xend=il_xend & |
|---|
| 11 | ,ybegin=il_ybegin,yend=il_yend) |
|---|
| 12 | allocate(data3D(1:il_xend-il_xbegin+1,1:il_yend-il_ybegin+1,1:1)) |
|---|
| 13 | data3D = RESHAPE( data, SHAPE(data3D) ) |
|---|
| 14 | call mpp_write( unit, field, domain, data3D, tstamp ) |
|---|
| 15 | data = RESHAPE( data3D, SHAPE(data) ) |
|---|
| 16 | deallocate(data3D) |
|---|
| 17 | |
|---|
| 18 | return |
|---|
| 19 | end subroutine MPP_WRITE_2DDECOMP_1D_ |
|---|
| 20 | |
|---|
| 21 | subroutine MPP_WRITE_2DDECOMP_2D_( unit, field, domain, data, tstamp ) |
|---|
| 22 | integer, intent(in) :: unit |
|---|
| 23 | type(fieldtype), intent(in) :: field |
|---|
| 24 | type(domain2D), intent(inout) :: domain |
|---|
| 25 | MPP_TYPE_, intent(inout) :: data(:,:) |
|---|
| 26 | real(DOUBLE_KIND), intent(in), optional :: tstamp |
|---|
| 27 | MPP_TYPE_ :: data3D(size(data,1),size(data,2),1) |
|---|
| 28 | #ifdef use_CRI_pointers |
|---|
| 29 | pointer( ptr, data3D ) |
|---|
| 30 | ptr = LOC(data) |
|---|
| 31 | call mpp_write( unit, field, domain, data3D, tstamp ) |
|---|
| 32 | #else |
|---|
| 33 | data3D = RESHAPE( data, SHAPE(data3D) ) |
|---|
| 34 | call mpp_write( unit, field, domain, data3D, tstamp ) |
|---|
| 35 | data = RESHAPE( data3D, SHAPE(data) ) |
|---|
| 36 | #endif |
|---|
| 37 | return |
|---|
| 38 | end subroutine MPP_WRITE_2DDECOMP_2D_ |
|---|
| 39 | |
|---|
| 40 | subroutine MPP_WRITE_2DDECOMP_3D_( unit, field, domain, data, tstamp ) |
|---|
| 41 | !mpp_write writes <data> which has the domain decomposition <domain> |
|---|
| 42 | integer, intent(in) :: unit |
|---|
| 43 | type(fieldtype), intent(in) :: field |
|---|
| 44 | type(domain2D), intent(inout) :: domain !must have intent(out) as well because active domain might be reset |
|---|
| 45 | MPP_TYPE_, intent(inout) :: data(:,:,:) |
|---|
| 46 | real(DOUBLE_KIND), intent(in), optional :: tstamp |
|---|
| 47 | !cdata is used to store compute domain as contiguous data |
|---|
| 48 | !gdata is used to globalize data for multi-PE single-threaded I/O |
|---|
| 49 | MPP_TYPE_, allocatable, dimension(:,:,:) :: cdata, gdata |
|---|
| 50 | !NEW: data may be on compute OR data domain |
|---|
| 51 | logical :: data_has_halos, halos_are_global, x_is_global, y_is_global |
|---|
| 52 | integer :: is, ie, js, je, isd, ied, jsd, jed, isg, ieg, jsg, jeg |
|---|
| 53 | |
|---|
| 54 | if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_WRITE: must first call mpp_io_init.' ) |
|---|
| 55 | if( .NOT.mpp_file(unit)%opened )call mpp_error( FATAL, 'MPP_WRITE: invalid unit number.' ) |
|---|
| 56 | call mpp_get_compute_domain( domain, is, ie, js, je ) |
|---|
| 57 | call mpp_get_data_domain ( domain, isd, ied, jsd, jed, x_is_global=x_is_global, y_is_global=y_is_global ) |
|---|
| 58 | call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg ) |
|---|
| 59 | if( size(data,1).EQ.ie-is+1 .AND. size(data,2).EQ.je-js+1 )then |
|---|
| 60 | data_has_halos = .FALSE. |
|---|
| 61 | else if( size(data,1).EQ.ied-isd+1 .AND. size(data,2).EQ.jed-jsd+1 )then |
|---|
| 62 | data_has_halos = .TRUE. |
|---|
| 63 | else |
|---|
| 64 | call mpp_error( FATAL, 'MPP_WRITE: data must be either on compute domain or data domain.' ) |
|---|
| 65 | end if |
|---|
| 66 | halos_are_global = x_is_global .AND. y_is_global |
|---|
| 67 | if( npes.GT.1 .AND. mpp_file(unit)%threading.EQ.MPP_SINGLE )then |
|---|
| 68 | if( halos_are_global )then |
|---|
| 69 | call mpp_update_domains( data, domain ) |
|---|
| 70 | !all non-0 PEs have passed their data to PE 0 and may now exit |
|---|
| 71 | if( pe.NE.0 )return |
|---|
| 72 | call write_record( unit, field, size(data), data, tstamp ) |
|---|
| 73 | else |
|---|
| 74 | !put field onto global domain |
|---|
| 75 | allocate( gdata(isg:ieg,jsg:jeg,size(data,3)) ) |
|---|
| 76 | call mpp_global_field( domain, data, gdata ) |
|---|
| 77 | !all non-0 PEs have passed their data to PE 0 and may now exit |
|---|
| 78 | if( pe.NE.0 )return |
|---|
| 79 | call write_record( unit, field, size(gdata), gdata, tstamp ) |
|---|
| 80 | end if |
|---|
| 81 | else if( data_has_halos )then |
|---|
| 82 | !store compute domain as contiguous data and pass to write_record |
|---|
| 83 | allocate( cdata(is:ie,js:je,size(data,3)) ) |
|---|
| 84 | cdata(:,:,:) = data(is-isd+1:ie-isd+1,js-jsd+1:je-jsd+1,:) |
|---|
| 85 | call write_record( unit, field, size(cdata), cdata, tstamp, domain ) |
|---|
| 86 | else |
|---|
| 87 | !data is already contiguous |
|---|
| 88 | call write_record( unit, field, size(data), data, tstamp, domain ) |
|---|
| 89 | end if |
|---|
| 90 | return |
|---|
| 91 | end subroutine MPP_WRITE_2DDECOMP_3D_ |
|---|
